| |
下記マクロを実行するととんでもなく時間がかかり悩んでいます
始めは快調に進むのですが最後は張り付いたように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
|
|
つよぽん
- 09/12/31(木) 6:33 -
