Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18267 / 76732 ←次へ | 前へ→

【63908】マクロを早く快適に動かしたいです
質問  つよぽん  - 09/12/31(木) 6:33 -

引用なし
パスワード
   下記マクロを実行するととんでもなく時間がかかり悩んでいます
始めは快調に進むのですが最後は張り付いたように15時間ほどかかります
なんとか早くするにはどうしたらよいものでしょうか?
行いたいのはフォルダ内にあるそれぞれのフォルダのデータを統合したいのです。
小さいデータなら問題なく動くのですが…よろしくお願いします

Sub 月間データ統合()
Dim dataFolder As String
Dim tmpSheet As Worksheet
Dim subFolder As String
Dim lastRow As Long
Dim fileName As String
Dim R As Long
Dim i As Long
Dim isOpen As Boolean
Dim book As Workbook
Dim csv As Workbook
Application.ScreenUpdating = False
dataFolder = "C:\Documents and Settings\月間データ統合" 'データフォルダ
Set tmpSheet = Sheets("Sheet1") '作業シート
tmpSheet.Cells.Clear '作業シートクリア
'フォルダ名取得
R = 1 '出力行の初期値
subFolder = Dir(dataFolder & "\", vbDirectory) 'データフォルダ内のフォルダとファイルを取得
Do While subFolder <> "" 'なくなるまで
If (GetAttr(dataFolder & "\" & subFolder) And vbDirectory) = vbDirectory Then 'ディレクトリで
If subFolder <> "." And subFolder <> ".." Then ' 現在のフォルダと親フォルダでなければ
tmpSheet.Range("A" & R) = subFolder '作業シートのA列にフォルダ名を表示
R = R + 1 '出力行+1
End If
End If
subFolder = Dir '次のフォルダ名を取得
Loop
'csvファイル名取得
lastRow = tmpSheet.Range("A" & Rows.Count).End(xlUp).Row '作業シートのA列の最終行
R = 1 '出力行の初期値
For i = 1 To lastRow
fileName = Dir(dataFolder & "\" & tmpSheet.Range("A" & i).Value & "\*.csv") 'フォルダ内の最初のcsvファイル名を取得
Do While fileName <> "" 'csvファイルがある間
tmpSheet.Range("B" & R) = Left(fileName, InStrRev(fileName, ".") - 1) '作業シートのB列にcsvファイル名の名前のみ取得
tmpSheet.Range("C" & R) = tmpSheet.Range("A" & i).Value '作業シートのC列にフォルダ名(日付)取得
R = R + 1 '出力行+1
fileName = Dir '次のcsvファイルを取得
Loop
Next
'ファイル名、フォルダ名で並べ替え
tmpSheet.Columns("B:C").Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=tmpSheet.Range("C1"), Order2:=xlAscending, Header:=xlNo
'bookへcsvファイルを集計
lastRow = tmpSheet.Range("B" & Rows.Count).End(xlUp).Row '作業シートのB列の最終行取得
isOpen = False '集計ブックが開いているかどうかのフラグの初期値(閉じている)
For R = 1 To lastRow 'B列の行数回
fileName = dataFolder & "\" & tmpSheet.Range("C" & R).Value & "\" & tmpSheet.Range("B" & R).Value & ".csv" 'csvファイルのファイル名取得
Set csv = Workbooks.Open(fileName) 'csvファイルを取得
If Not isOpen Then '集計ブックが開いていなければ
csv.Sheets(1).Copy 'csvファイルを新しいブックへコピー
Set book = ActiveWorkbook '新しいブックactiveになっているので、book変数に取得
isOpen = True '集計ブックフラグをありにする
Else 'すでに集計ブックが開いていたら
csv.Sheets(1).Copy After:=book.Sheets(book.Sheets.Count) '集計ブックの最後のシートの後ろにコピー
End If
book.Sheets(book.Sheets.Count).Name = tmpSheet.Range("C" & R).Value 'コピーしたシートの名前を日付にする
csv.Close False 'csvファイルを閉じる
If tmpSheet.Range("B" & R).Value <> tmpSheet.Range("B" & R + 1).Value Then '次のB列の値が違っていたら
Application.DisplayAlerts = False

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "total"

  Range("A1").Select

  Dim ws As Worksheet
  Dim wsT As Worksheet
  Dim Ranges() As String, N As Long
  Set wsT = ActiveWorkbook.Worksheets("total")
  For Each ws In ActiveWorkbook.Worksheets
    If Not ws Is wsT Then
      N = N + 1
      ReDim Preserve Ranges(1 To N)
      With ws
        Ranges(N) = .Range("B1", .Cells(.Rows.Count, 3).End(xlUp)) _
               .Address(, , xlR1C1, True)
      End With
    End If
  Next
  With wsT
    .UsedRange.ClearContents
    .Range("A1").Consolidate Sources:=Ranges, Function:=xlSum, _
              TopRow:=False, LeftColumn:=True
  End With
    Columns("A:B").Select
  ActiveWorkbook.Worksheets("total").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("total").Sort.SortFields.Add Key:=Range("A1"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("total").Sort
    .SetRange Range("A1:B10000")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  Range("A1").Select
   Columns("A:A").Select
  Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  Columns("B:B").Select
  Selection.Copy
  Columns("A:A").Select
  ActiveSheet.Paste
  Range("A1").Select
book.SaveAs dataFolder & "\" & tmpSheet.Range("B" & R).Value & ".csv", _
      FileFormat:=xlCSV, CreateBackup:=False '集計ブックを作業シートのB列の値(シート名)で保存
book.Close False '集計ブックを閉じる
isOpen = False '集計ブックが開いているかフラグを閉じているにする
End If
Next
Application.ScreenUpdating = True
End Sub

0 hits

【63908】マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 6:33 質問
【63910】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 10:40 発言
【63914】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 14:09 発言
【63916】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 15:13 発言
【63917】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 15:19 発言
【63918】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:31 回答
【63919】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:36 回答
【63921】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 17:12 回答
【63927】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 18:03 回答
【63928】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:10 発言
【63932】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 19:07 発言
【63933】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 19:40 発言
【63935】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 20:33 発言
【63936】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:01 発言
【63939】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:32 質問
【63940】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 18:39 発言
【63942】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 19:16 お礼
【63948】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 22:23 発言
【63949】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:21 発言
【63950】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:29 発言
【63920】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 17:08 発言
【63924】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 17:48 発言
【63925】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 17:53 発言
【63929】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:41 発言
【63931】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:50 発言
【63937】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:04 発言
【63934】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 20:14 発言
【63938】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 22:54 発言
【63941】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:57 発言
【63943】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 19:41 発言
【63930】Re:マクロを早く快適に動かしたいです よろずや 09/12/31(木) 18:44 発言
【63944】Re:マクロを早く快適に動かしたいです Yuki 10/1/2(土) 10:46 発言
【63945】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/2(土) 11:11 発言

18267 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free