Excel VBA質問箱 IV

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

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


3143 / 13644 ツリー ←次へ | 前へ→

【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 発言[未読]

【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

【63910】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 10:40 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>なんとか早くするにはどうしたらよいものでしょうか?

Excelのバージョンは2007でしょうか?
できれば、バージョンも書いておいていただいたほうがいいかと思います。

提示されたコードは、インデントがないので、少し修正をさせていただきました。
以下のようなコードで見易さについてどのようにお感じになりますでしょうか?

その上で、処理の先頭で、再計算モードを手動にして、処理の最後で自動に戻す
ようにしてはいかがでしょうか?
具体的には、★の行の記述です。

なお、コードがExcel2007のようで、当方では環境がないので、検証はしていません。

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
   
 Dim ws As Worksheet
 Dim wsT As Worksheet
 Dim Ranges() As String, N As Long
 
 Application.ScreenUpdating = False
 Application.Calculation = xlManual '★
  
 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
   
   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.Calculation = xlAutomatic '★
 Application.ScreenUpdating = True
End Sub

【63914】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 09/12/31(木) 14:09 -

引用なし
パスワード
   ▼つよぽん さん:
横からすみません。

>下記マクロを実行するととんでもなく時間がかかり悩んでいます
>始めは快調に進むのですが最後は張り付いたように15時間ほどかかります
>なんとか早くするにはどうしたらよいものでしょうか?
>行いたいのはフォルダ内にあるそれぞれのフォルダのデータを統合したいのです。

「統合」は便利な一般機能ですが、
時間のかかる処理なので、

サブフォルダ内のすべてのCSVファイルを
Dictionaryなどを利用してメモリ内で統合するようにすれば
格段に速くなると思いますよ。

CSVファイルのデータ形式のサンプルがあると、
こちらも時間のあるときに考えてみることができるのですが。。。

【63916】Re:マクロを早く快適に動かしたいです
発言  つよぽん  - 09/12/31(木) 15:13 -

引用なし
パスワード
   かみちゃんさん、お返事ありがとうございます。
Excelのバージョンは2007です。


kanabunさん、お返事ありがとうございます。
csvのサンプルはどのようにアップすればよいのでしょうか?
csvデータは簡単なもので1行目からA列に時間、B列に商品名、C列に販売個数が書いてます。
時間毎にデータが並んでいるため商品の順番は不同で重複もしています。
このデータが1日5000行くらいで1400店舗あり、1ヶ月で20日ほどのデータになります。
これを1400店舗でそれぞれ商品ごとの1ヶ月の販売個数を統合したいのです。
そして、統合後のデータはA列に商品名、B列にも同じ商品名、C列に1ヶ月の総販売個数を表示したいのです。

よろしくお願いします。

【63917】Re:マクロを早く快適に動かしたいです
発言  かみちゃん E-MAIL  - 09/12/31(木) 15:19 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>csvのサンプルはどのようにアップすればよいのでしょうか?
>csvデータは簡単なもので1行目からA列に時間、B列に商品名、C列に販売個数が書いてます。
>時間毎にデータが並んでいるため商品の順番は不同で重複もしています。

以下のような感じのデータなのでしょうか?

2009/12/31 15:00:00,商品名C,100
2009/12/31 15:01:00,商品名B,200
2009/12/31 15:02:00,商品名A,120
2009/12/31 15:03:00,商品名B,110

違っているならば、このような感じで、サンプルデータを示してみてください。

> 統合後のデータはA列に商品名、B列にも同じ商品名、C列に1ヶ月の総販売個数を表示したい

A列とB列に同じ商品名とはどういうイメージなのでしょうか?
提示されたサンプルデータを使って、どのような結果を期待しているか以下のようなイメージで説明していただければありがたいです。

   A   B   C
1
2
3

【63918】Re:マクロを早く快適に動かしたいです
回答  Hirofumi  - 09/12/31(木) 15:31 -

引用なし
パスワード
   Csvのサンプルが無いのと、結果のサンプルが無いのでテスト出来ませんが
概ねこんなかな?

Option Explicit

Sub 月間データ統合_2()

  Dim dataFolder As String
  Dim fileName As String
  Dim r As Long
  Dim i As Long
  Dim vntFileNames() As Variant
  Dim dfn As Integer
  Dim strBuff As String
  Dim vntField As Variant
  Dim lngIndex() As Long
  Dim vntKeys As Variant
  Dim dicIndex As Object
      
'  Application.ScreenUpdating = False
  
  'データフォルダ
'  dataFolder = "C:\Documents and Settings\月間データ統合"
  dataFolder = ThisWorkbook.Path & "\BBB"
  '※csvファイル名取得
  FileList dataFolder, vntFileNames, Sheets("Sheet1")
    
  '※bookへcsvファイルを集計
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'B列の行数回
  For r = 1 To UBound(vntFileNames, 1) - 1
    '次のB列の値が違っていたら(csvファイル名が違っていたら)
    If vntFileNames(r, 1) <> vntFileNames(r + 1, 1) Then
      With dicIndex
        If .Count > 0 Then
          'Dictionaryの全てのKeyを出力
          vntKeys = dicIndex.Keys
          '結果用配列を確保
          ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 3), _
              lngIndex(1 To UBound(vntKeys) + 1)
          '結果を配列に出力
          For i = 0 To UBound(vntKeys)
            vntField(i + 1, 1) = vntKeys(i)
            vntField(i + 1, 2) = vntField(i + 1, 1)
            vntField(i + 1, 3) = .Item(vntKeys(i))
            'Indexを作成
            lngIndex(i + 1) = i + 1
          Next i
          'Dictionaryをクリア
          .RemoveAll
          '配列を2列目をKeyに整列
          ShellSort vntField, lngIndex, 2
          '出力ファイルをOpen
          fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
          dfn = FreeFile
          Open fileName For Output As dfn
          'ファイルに出力
          For i = 1 To UBound(vntField, 1)
            Print #dfn, vntField(i, 1) & "," & vntField(i, 2) & "," & vntField(i, 3)
          Next i
          'ファイルをClose
          Close dfn
        End If
      End With
    Else
      'csvファイルのファイル名取得
      fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
      'csvファイルをOpen
      dfn = FreeFile
      Open fileName For Input As dfn
      'ファイルエンドまで繰り返し
      Do Until EOF(dfn)
        'Csvからいレコード読み込み
        Line Input #dfn, strBuff
        '読み込んだレコードをフィールドに分割
        vntField = SplitCsv(strBuff, ",")
        With dicIndex
          If .Exists(vntField(1)) Then
            .Item(vntField(1)) = .Item(vntField(1)) + Val(vntField(2))
          Else
            .Add vntField(1), Val(vntField(2))
          End If
        End With
      Loop
      'csvファイルを閉じる
      Close dfn
    End If
  Next r
  
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = True

End Sub

Private Sub FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet)

  Dim i As Long
  Dim r As Long
  Dim strName As String
  Dim strSFolder() As String
  Dim strFiles() As String
  
  '※フォルダ名取得
  
   'データフォルダ内のフォルダとファイルを取得
  strName = Dir(strPath & "\", vbDirectory)
  'なくなるまで
  Do While strName <> ""
    'ディレクトリで
    If (GetAttr(strPath & "\" & strName) And vbDirectory) = vbDirectory Then
      ' 現在のフォルダと親フォルダでなければ
      If strName <> "." And strName <> ".." Then
        '配列にサブフォルダ名を列挙
        r = r + 1
        ReDim Preserve strSFolder(1 To r)
        strSFolder(r) = strName
      End If
    End If
    '次のフォルダ名を取得
    strName = Dir
  Loop
  
  '※csvファイル名取得
  r = 0
  For i = 1 To UBound(strSFolder)
    'フォルダ内の最初のcsvファイル名を取得
    strName = Dir(strPath & "\" & strSFolder(i) & "\*.csv")
    'csvファイルがある間
    Do While strName <> ""
      r = r + 1
      ReDim Preserve strFiles(1 To 2, 1 To r)
      '作業シートのB列にcsvファイル名の名前のみ取得
      strFiles(1, r) = Left(strName, InStrRev(strName, ".") - 1)
      '作業シートのC列にフォルダ名(日付)取得
      strFiles(2, r) = strSFolder(i)
      '次のcsvファイルを取得
      strName = Dir
    Loop
  Next
  
  With wksWork
    '作業シートクリア
    .Cells.Clear
    'データ出力
    .Range("B1").Resize(r, 2).Value = Application.WorksheetFunction.Transpose(strFiles)
    'ファイル名、フォルダ名で並べ替え
    .Range("B1").Resize(r, 2).Sort _
        Key1:=.Range("B1"), Order1:=xlAscending, _
        Key2:=.Range("C1"), Order2:=xlAscending, _
        Header:=xlNo
    'ファイル名を配列に取得
    vntFileNames = .Range("B1").Resize(r + 1, 2).Value
  End With

End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Sub ShellSort(vntList As Variant, _
            lngIndex() As Long, _
            Optional lngKey As Long = 1)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim lngTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap = 0
    For i = lngGap + lngTop To lngEnd
      lngTmp = lngIndex(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(lngIndex(j - lngGap), lngKey) _
                  <= vntList(lngTmp, lngKey) Then
          Exit For
        End If
        lngIndex(j) = lngIndex(j - lngGap)
      Next j
      lngIndex(j) = lngTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【63919】Re:マクロを早く快適に動かしたいです
回答  Hirofumi  - 09/12/31(木) 15:36 -

引用なし
パスワード
   ごめん、一部間違えていました

Option Explicit
Option Compare Text

Sub 月間データ統合_2()

  Dim dataFolder As String
  Dim fileName As String
  Dim r As Long
  Dim i As Long
  Dim vntFileNames() As Variant
  Dim dfn As Integer
  Dim strBuff As String
  Dim vntField As Variant
  Dim lngIndex() As Long
  Dim vntKeys As Variant
  Dim dicIndex As Object
      
  Application.ScreenUpdating = False
  
  'データフォルダ
  dataFolder = "C:\Documents and Settings\月間データ統合"
  '※csvファイル名取得
  FileList dataFolder, vntFileNames, Sheets("Sheet1")
    
  '※bookへcsvファイルを集計
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'B列の行数回
  For r = 1 To UBound(vntFileNames, 1) - 1
    '次のB列の値が違っていたら(csvファイル名が違っていたら)
    If vntFileNames(r, 1) <> vntFileNames(r + 1, 1) Then
      With dicIndex
        If .Count > 0 Then
          'Dictionaryの全てのKeyを出力
          vntKeys = dicIndex.Keys
          '結果用配列を確保
          ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 3), _
              lngIndex(1 To UBound(vntKeys) + 1)
          '結果を配列に出力
          For i = 0 To UBound(vntKeys)
            vntField(i + 1, 1) = vntKeys(i)
            vntField(i + 1, 2) = vntField(i + 1, 1)
            vntField(i + 1, 3) = .Item(vntKeys(i))
            'Indexを作成
            lngIndex(i + 1) = i + 1
          Next i
          'Dictionaryをクリア
          .RemoveAll
          '配列を2列目をKeyに整列
          ShellSort vntField, lngIndex, 2
          '出力ファイルをOpen
          fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
          dfn = FreeFile
          Open fileName For Output As dfn
          'ファイルに出力
          For i = 1 To UBound(vntField, 1)
            Print #dfn, vntField(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 2) & "," _
                  & vntField(lngIndex(i), 3)
          Next i
          'ファイルをClose
          Close dfn
        End If
      End With
    Else
      'csvファイルのファイル名取得
      fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
      'csvファイルをOpen
      dfn = FreeFile
      Open fileName For Input As dfn
      'ファイルエンドまで繰り返し
      Do Until EOF(dfn)
        'Csvからいレコード読み込み
        Line Input #dfn, strBuff
        '読み込んだレコードをフィールドに分割
        vntField = SplitCsv(strBuff, ",")
        With dicIndex
          If .Exists(vntField(1)) Then
            .Item(vntField(1)) = .Item(vntField(1)) + Val(vntField(2))
          Else
            .Add vntField(1), Val(vntField(2))
          End If
        End With
      Loop
      'csvファイルを閉じる
      Close dfn
    End If
  Next r
  
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = True

End Sub

Private Sub FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet)

  Dim i As Long
  Dim r As Long
  Dim strName As String
  Dim strSFolder() As String
  Dim strFiles() As String
  
  '※フォルダ名取得
  
   'データフォルダ内のフォルダとファイルを取得
  strName = Dir(strPath & "\", vbDirectory)
  'なくなるまで
  Do While strName <> ""
    'ディレクトリで
    If (GetAttr(strPath & "\" & strName) And vbDirectory) = vbDirectory Then
      ' 現在のフォルダと親フォルダでなければ
      If strName <> "." And strName <> ".." Then
        '配列にサブフォルダ名を列挙
        r = r + 1
        ReDim Preserve strSFolder(1 To r)
        strSFolder(r) = strName
      End If
    End If
    '次のフォルダ名を取得
    strName = Dir
  Loop
  
  '※csvファイル名取得
  r = 0
  For i = 1 To UBound(strSFolder)
    'フォルダ内の最初のcsvファイル名を取得
    strName = Dir(strPath & "\" & strSFolder(i) & "\*.csv")
    'csvファイルがある間
    Do While strName <> ""
      r = r + 1
      ReDim Preserve strFiles(1 To 2, 1 To r)
      '作業シートのB列にcsvファイル名の名前のみ取得
      strFiles(1, r) = Left(strName, InStrRev(strName, ".") - 1)
      '作業シートのC列にフォルダ名(日付)取得
      strFiles(2, r) = strSFolder(i)
      '次のcsvファイルを取得
      strName = Dir
    Loop
  Next
  
  With wksWork
    '作業シートクリア
    .Cells.Clear
    'データ出力
    .Range("B1").Resize(r, 2).Value = Application.WorksheetFunction.Transpose(strFiles)
    'ファイル名、フォルダ名で並べ替え
    .Range("B1").Resize(r, 2).Sort _
        Key1:=.Range("B1"), Order1:=xlAscending, _
        Key2:=.Range("C1"), Order2:=xlAscending, _
        Header:=xlNo
    'ファイル名を配列に取得
    vntFileNames = .Range("B1").Resize(r + 1, 2).Value
  End With

End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Sub ShellSort(vntList As Variant, _
            lngIndex() As Long, _
            Optional lngKey As Long = 1)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim lngTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap = 0
    For i = lngGap + lngTop To lngEnd
      lngTmp = lngIndex(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(lngIndex(j - lngGap), lngKey) _
                  <= vntList(lngTmp, lngKey) Then
          Exit For
        End If
        lngIndex(j) = lngIndex(j - lngGap)
      Next j
      lngIndex(j) = lngTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【63920】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 09/12/31(木) 17:08 -

引用なし
パスワード
   ▼つよぽん さん:

もうすでにサンプルコードの提示がありますが、
ひとつのCSVファイルのデータレイアウトは
かみちゃんさんが例示されているような形式と考えれば
よろしいのでしょうか?

>1日5000行くらいで

ということは、
ひとつのCSVには ある店舗のある日の(5000行くらい)のデータが
入っているということですか?

> 1400店舗あり、
店舗別に サブフォルダがあるということですか?

>1ヶ月で20日ほどのデータになります。
ひとつのサブフォルダの中には
20ほどの日付別 CSVファイルが入っているということですか?

【63921】Re:マクロを早く快適に動かしたいです
回答  Hirofumi  - 09/12/31(木) 17:12 -

引用なし
パスワード
   あ!、善く見たら、先頭のCsvのファイル名が下のファイル名と違った場合
集計されない事が解りました

以下に修正したコードをUpします
Option Explicit
Option Compare Text

Sub 月間データ統合_3()

  Dim dataFolder As String
  Dim fileName As String
  Dim r As Long
  Dim i As Long
  Dim vntFileNames() As Variant
  Dim dfn As Integer
  Dim strBuff As String
  Dim vntField As Variant
  Dim lngIndex() As Long
  Dim vntKeys As Variant
  Dim dicIndex As Object
  Dim strPrompt As String
      
'  Application.ScreenUpdating = False
  
  'データフォルダ
'  dataFolder = "C:\Documents and Settings\月間データ統合"
  dataFolder = ThisWorkbook.Path & "\BBB"
  '※csvファイル名取得
  If Not FileList(dataFolder, vntFileNames, Sheets("Sheet1")) Then
    strPrompt = "ファイルが有りません"
    GoTo Wayout
  End If
    
  '※bookへcsvファイルを集計
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'csvファイルのファイル名取得
  fileName = dataFolder & "\" & vntFileNames(1, 2) & "\" & vntFileNames(1, 1) & ".csv"
  'データ取得
  GetData fileName, dicIndex
  'B列の行数回-1
  For r = 2 To UBound(vntFileNames, 1) - 1
    '次のB列の値が違っていたら(csvファイル名が違っていたら)
    If vntFileNames(r - 1, 1) <> vntFileNames(r, 1) Then
      With dicIndex
        'Dictionaryの全てのKeyを出力
        vntKeys = dicIndex.Keys
        '結果用配列を確保
        ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 2), _
            lngIndex(1 To UBound(vntKeys) + 1)
        '結果を配列に出力
        For i = 0 To UBound(vntKeys)
          vntField(i + 1, 1) = vntKeys(i)
          vntField(i + 1, 2) = .Item(vntKeys(i))
          'Indexを作成
          lngIndex(i + 1) = i + 1
        Next i
        'Dictionaryをクリア
        .RemoveAll
        '配列を2列目をKeyに整列
        ShellSort vntField, lngIndex, 1
        '出力ファイルをOpen
        fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
        dfn = FreeFile
        Open fileName For Output As dfn
        'ファイルに出力
        For i = 1 To UBound(vntField, 1)
          Print #dfn, vntField(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 2)
        Next i
        'ファイルをClose
        Close dfn
      End With
    Else
      'csvファイルのファイル名取得
      fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
      'データ取得
      GetData fileName, dicIndex
    End If
  Next r
  
  strPrompt = "処理が完了しました"
  
Wayout:
 
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = True
  
  MsgBox strPrompt, vbInformation

End Sub

Private Sub GetData(strFile As String, dicIndex As Object)

  Dim i As Long
  Dim vntField As Variant
  Dim dfn As Integer
  Dim strBuff As String
  
  'csvファイルをOpen
  dfn = FreeFile
  Open strFile For Input As dfn
      
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'Csvからいレコード読み込み
    Line Input #dfn, strBuff
    '読み込んだレコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",")
    With dicIndex
      If .Exists(vntField(1)) Then
        .Item(vntField(1)) = .Item(vntField(1)) + Val(vntField(2))
      Else
        .Add vntField(1), Val(vntField(2))
      End If
    End With
  Loop
  
  'csvファイルを閉じる
  Close dfn
  
End Sub

Private Function FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet) As Boolean

  Dim i As Long
  Dim r As Long
  Dim strName As String
  Dim strSFolder() As String
  Dim strFiles() As String
  
  '※フォルダ名取得
  
   'データフォルダ内のフォルダとファイルを取得
  strName = Dir(strPath & "\", vbDirectory)
  'なくなるまで
  Do While strName <> ""
    'ディレクトリで
    If (GetAttr(strPath & "\" & strName) And vbDirectory) = vbDirectory Then
      ' 現在のフォルダと親フォルダでなければ
      If strName <> "." And strName <> ".." Then
        '配列にサブフォルダ名を列挙
        r = r + 1
        ReDim Preserve strSFolder(1 To r)
        strSFolder(r) = strName
      End If
    End If
    '次のフォルダ名を取得
    strName = Dir
  Loop
  
  If r < 1 Then
    Exit Function
  End If
  
  '※csvファイル名取得
  r = 0
  For i = 1 To UBound(strSFolder)
    'フォルダ内の最初のcsvファイル名を取得
    strName = Dir(strPath & "\" & strSFolder(i) & "\*.csv")
    'csvファイルがある間
    Do While strName <> ""
      r = r + 1
      ReDim Preserve strFiles(1 To 2, 1 To r)
      '作業シートのB列にcsvファイル名の名前のみ取得
      strFiles(1, r) = Left(strName, InStrRev(strName, ".") - 1)
      '作業シートのC列にフォルダ名(日付)取得
      strFiles(2, r) = strSFolder(i)
      '次のcsvファイルを取得
      strName = Dir
    Loop
  Next
  
  If r < 1 Then
    Exit Function
  End If
  
  With wksWork
    '作業シートクリア
    .Cells.Clear
    'データ出力
    .Range("B1").Resize(r, 2).Value = Application.WorksheetFunction.Transpose(strFiles)
    'ファイル名、フォルダ名で並べ替え
    .Range("B1").Resize(r, 2).Sort _
        Key1:=.Range("B1"), Order1:=xlAscending, _
        Key2:=.Range("C1"), Order2:=xlAscending, _
        Header:=xlNo
    'ファイル名を配列に取得
    vntFileNames = .Range("B1").Resize(r + 1, 2).Value
  End With

  FileList = True
  
End Function

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Sub ShellSort(vntList As Variant, _
            lngIndex() As Long, _
            Optional lngKey As Long = 1)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim lngTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap = 0
    For i = lngGap + lngTop To lngEnd
      lngTmp = lngIndex(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(lngIndex(j - lngGap), lngKey) _
                  <= vntList(lngTmp, lngKey) Then
          Exit For
        End If
        lngIndex(j) = lngIndex(j - lngGap)
      Next j
      lngIndex(j) = lngTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【63924】Re:マクロを早く快適に動かしたいです
発言  つよぽん  - 09/12/31(木) 17:48 -

引用なし
パスワード
   皆さんありがとうございます。
データはかみちゃんさんのご想像通りです。

もう少し細かくお伝えすると、統合フォルダの中に20091201フォルダ、20091202フォルダと日付フォルダがあり、
日付フォルダの中には1001csv、1002csv、1003csvと1400の店舗データがあります。
そのcsvファイルには
  時間   商品名   商品数
1  0830  100101   1
2  0831  100105   3
3  0831  102001   10
4  0840  100105   5
となっているのを

   商品名  商品名  商品数
1  100101  100101    1001ヶ月の販売数
2  100105  100105    800
3  102001  102001    100
と店舗毎の1ヶ月の商品の総数を統合したcsvを作りたいのです

よろしくお願いします。

【63925】Re:マクロを早く快適に動かしたいです
発言  かみちゃん E-MAIL  - 09/12/31(木) 17:53 -

引用なし
パスワード
   >ご想像通りです。

ということは、

>  時間   商品名   商品数

というタイトル行は、ないということでしょうか?

>と店舗毎の1ヶ月の商品の総数を統合したcsvを作りたい

作りたいのも、ワークシートではなく、CSVファイルなのですか?

Hirofumiさんが提示されたコードは、試されたのでしょうか?

【63927】Re:マクロを早く快適に動かしたいです
回答  Hirofumi  - 09/12/31(木) 18:03 -

引用なし
パスワード
   ゴメン、なんかとちくるって、集計が上手く行かない?
多分、これで善いと思います

Option Explicit
Option Compare Text

Sub 月間データ統合_4()

  Dim dataFolder As String
  Dim fileName As String
  Dim r As Long
  Dim i As Long
  Dim vntFileNames() As Variant
  Dim dfn As Integer
  Dim strBuff As String
  Dim vntField As Variant
  Dim lngIndex() As Long
  Dim vntKeys As Variant
  Dim dicIndex As Object
  Dim strPrompt As String
      
  Application.ScreenUpdating = False
  
  'データフォルダ
  dataFolder = "C:\Documents and Settings\月間データ統合"
  '※csvファイル名取得
  If Not FileList(dataFolder, vntFileNames, Sheets("Sheet1")) Then
    strPrompt = "ファイルが有りません"
    GoTo Wayout
  End If
    
  '※bookへcsvファイルを集計
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'csvファイルのファイル名取得
  fileName = dataFolder & "\" & vntFileNames(1, 2) & "\" & vntFileNames(1, 1) & ".csv"
  'データ取得
  GetData fileName, dicIndex
  'B列の行数回-1
  For r = 2 To UBound(vntFileNames, 1)
    '次のB列の値が違っていたら(csvファイル名が違っていたら)
    If vntFileNames(r - 1, 1) <> vntFileNames(r, 1) Then
      With dicIndex
        'Dictionaryの全てのKeyを出力
        vntKeys = dicIndex.Keys
        '結果用配列を確保
        ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 2), _
            lngIndex(1 To UBound(vntKeys) + 1)
        '結果を配列に出力
        For i = 0 To UBound(vntKeys)
          vntField(i + 1, 1) = vntKeys(i)
          vntField(i + 1, 2) = .Item(vntKeys(i))
          'Indexを作成
          lngIndex(i + 1) = i + 1
        Next i
        'Dictionaryをクリア
        .RemoveAll
        '配列を2列目をKeyに整列
        ShellSort vntField, lngIndex, 1
        '出力ファイルをOpen
        fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
        dfn = FreeFile
        Open fileName For Output As dfn
        'ファイルに出力
        For i = 1 To UBound(vntField, 1)
          Print #dfn, vntField(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 2)
        Next i
        'ファイルをClose
        Close dfn
      End With
    End If
    If vntFileNames(r, 1) <> "" Then
      'csvファイルのファイル名取得
      fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
      'データ取得
      GetData fileName, dicIndex
    End If
  Next r
  
  strPrompt = "処理が完了しました"
  
Wayout:
 
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = True
  
  MsgBox strPrompt, vbInformation

End Sub

Private Sub GetData(strFile As String, dicIndex As Object)

  Dim i As Long
  Dim vntField As Variant
  Dim dfn As Integer
  Dim strBuff As String
  
  'csvファイルをOpen
  dfn = FreeFile
  Open strFile For Input As dfn
      
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'Csvからいレコード読み込み
    Line Input #dfn, strBuff
    '読み込んだレコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",")
    With dicIndex
      If .Exists(vntField(1)) Then
        .Item(vntField(1)) = .Item(vntField(1)) + Val(vntField(2))
      Else
        .Add vntField(1), Val(vntField(2))
      End If
    End With
  Loop
  
  'csvファイルを閉じる
  Close dfn
  
End Sub

Private Function FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet) As Boolean

  Dim i As Long
  Dim r As Long
  Dim strName As String
  Dim strSFolder() As String
  Dim strFiles() As String
  
  '※フォルダ名取得
  
   'データフォルダ内のフォルダとファイルを取得
  strName = Dir(strPath & "\", vbDirectory)
  'なくなるまで
  Do While strName <> ""
    'ディレクトリで
    If (GetAttr(strPath & "\" & strName) And vbDirectory) = vbDirectory Then
      ' 現在のフォルダと親フォルダでなければ
      If strName <> "." And strName <> ".." Then
        '配列にサブフォルダ名を列挙
        r = r + 1
        ReDim Preserve strSFolder(1 To r)
        strSFolder(r) = strName
      End If
    End If
    '次のフォルダ名を取得
    strName = Dir
  Loop
  
  If r < 1 Then
    Exit Function
  End If
  
  '※csvファイル名取得
  r = 0
  For i = 1 To UBound(strSFolder)
    'フォルダ内の最初のcsvファイル名を取得
    strName = Dir(strPath & "\" & strSFolder(i) & "\*.csv")
    'csvファイルがある間
    Do While strName <> ""
      r = r + 1
      ReDim Preserve strFiles(1 To 2, 1 To r)
      '作業シートのB列にcsvファイル名の名前のみ取得
      strFiles(1, r) = Left(strName, InStrRev(strName, ".") - 1)
      '作業シートのC列にフォルダ名(日付)取得
      strFiles(2, r) = strSFolder(i)
      '次のcsvファイルを取得
      strName = Dir
    Loop
  Next
  
  If r < 1 Then
    Exit Function
  End If
  
  With wksWork
    '作業シートクリア
    .Cells.Clear
    'データ出力
    .Range("B1").Resize(r, 2).Value = Application.WorksheetFunction.Transpose(strFiles)
    'ファイル名、フォルダ名で並べ替え
    .Range("B1").Resize(r, 2).Sort _
        Key1:=.Range("B1"), Order1:=xlAscending, _
        Key2:=.Range("C1"), Order2:=xlAscending, _
        Header:=xlNo
    'ファイル名を配列に取得
    vntFileNames = .Range("B1").Resize(r + 1, 2).Value
  End With

  FileList = True
  
End Function

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Sub ShellSort(vntList As Variant, _
            lngIndex() As Long, _
            Optional lngKey As Long = 1)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim lngTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap = 0
    For i = lngGap + lngTop To lngEnd
      lngTmp = lngIndex(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(lngIndex(j - lngGap), lngKey) _
                  <= vntList(lngTmp, lngKey) Then
          Exit For
        End If
        lngIndex(j) = lngIndex(j - lngGap)
      Next j
      lngIndex(j) = lngTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【63928】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 18:10 -

引用なし
パスワード
   こんにちは。かみちゃん です。

▼Hirofumiさん

>集計が上手く行かない?
>多分、これで善いと思います

[63924]で、Csvのサンプルと、結果のサンプルが出ていて、こちらでも検証しましたが、
さっぱり上手く集計されませんよ。

>  dataFolder = "C:\Documents and Settings\月間データ統合"

こういうところからして、おかしいかなと。

【63929】Re:マクロを早く快適に動かしたいです
発言  かみちゃん E-MAIL  - 09/12/31(木) 18:41 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>データはかみちゃんさんのご想像通りです。

  時間   商品名   商品数
というタイトル行は、なく、

>と店舗毎の1ヶ月の商品の総数を統合した

ものをCSVファイルではなく、ワークシート上に出力するのでよければ、
Hirofumiさんのコードをお借りすると以下のような感じで集計できると思います。

マクロを記述するブックが保存されているフォルダに、
「月間データ統合」というフォルダがあり、その中に
20091201フォルダ、20091202フォルダというフォルダがあるものとします。

Option Explicit
Option Compare Text

Sub Sample()

  Dim dataFolder As String
  Dim fileName As String
  Dim i As Long
  Dim vntFileNames() As Variant
  Dim vntField As Variant
  Dim vntKeys As Variant
  Dim dicIndex As Object
  Dim strPrompt As String
   
  Application.ScreenUpdating = False
 
  'データフォルダ
  dataFolder = ThisWorkbook.Path & "\月間データ統合"
  '※csvファイル名取得
  If Not FileList(dataFolder, vntFileNames, Sheets("Sheet1")) Then
    strPrompt = "ファイルが有りません"
    GoTo Wayout
  End If
  
  '※bookへcsvファイルを集計
 
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(vntFileNames, 1) - 1
    'csvファイルのファイル名取得
    fileName = dataFolder & "\" & vntFileNames(i, 2) & "\" & vntFileNames(i, 1) & ".csv"
    'データ取得
    GetData fileName, dicIndex
  Next
      
  With dicIndex
    'Dictionaryの全てのKeyを出力
    vntKeys = dicIndex.Keys
    '結果用配列を確保
    ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 3)
    '結果を配列に出力
    For i = 0 To UBound(vntKeys)
      vntField(i + 1, 1) = vntKeys(i)
      vntField(i + 1, 2) = vntKeys(i)
      vntField(i + 1, 3) = .Item(vntKeys(i))
    Next i
    'Dictionaryをクリア
    .RemoveAll
  End With
  With Sheets("Sheet1")
   .Cells.Clear
   .Range("A1").Resize(UBound(vntField), 3).Value = vntField
  End With
 
  strPrompt = "処理が完了しました"
 
Wayout:
 
  Set dicIndex = Nothing
 
  Application.ScreenUpdating = True
 
  MsgBox strPrompt, vbInformation

End Sub

Private Sub GetData(strFile As String, dicIndex As Object)
 '〜省略〜
End Sub

Private Function FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet) As Boolean
 '〜省略〜
End Function

Private Function SplitCsv(ByVal strLine As String, _
 '〜省略〜
End Function

ワークシートを経由せずに、CSVファイルに直接出力することもできますが、
どのフォルダにどのようなファイル名で保存すればいいのかがわかりません。

【63930】Re:マクロを早く快適に動かしたいです
発言  よろずや  - 09/12/31(木) 18:44 -

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

明らかに Excel の処理能力を超えています。
Excel での開発は即刻中止して、データベースの導入を検討しましょう。

【63931】Re:マクロを早く快適に動かしたいです
発言  かみちゃん E-MAIL  - 09/12/31(木) 18:50 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>ワークシートを経由せずに、CSVファイルに直接出力することもできますが、
>どのフォルダにどのようなファイル名で保存すればいいのかがわかりません。

保存ファイル名が
月間データ統合フォルダの直下に、
月間データ統合フォルダ200912.csv
というようなファイル名でいいのであれば、

  With Sheets("Sheet1")
   .Cells.Clear
   .Range("A1").Resize(UBound(vntField), 3).Value = vntField
  End With

の部分を

  '出力ファイルをOpen
  fileName = dataFolder & "\月間データ統合" & Mid(vntFileNames(1, 2), 1, 6) & ".csv"
  dfn = FreeFile
  Open fileName For Output As dfn
  'ファイルに出力
  For i = 1 To UBound(vntField, 1)
    Print #dfn, vntField(i, 1) & "," _
            & vntField(i, 2) & "," _
            & vntField(i, 3)
  Next i
  'ファイルをClose
  Close dfn

とすればできます。

なお、この場合は、

  Dim dfn As Integer

という変数宣言が必要になります。

こちらで一通り検証してありますので、不都合があれば、言ってください。

ひとつ気がかりなのは、出力されたCSVファイル内の商品コードの順番は規則性(昇順、降順など)
が必要なのかどうかです。

【63932】Re:マクロを早く快適に動かしたいです
発言  Hirofumi  - 09/12/31(木) 19:07 -

引用なし
パスワード
   ▼かみちゃん さん:
>こんにちは。かみちゃん です。
>
>▼Hirofumiさん
>
>>集計が上手く行かない?
>>多分、これで善いと思います
>
>[63924]で、Csvのサンプルと、結果のサンプルが出ていて、こちらでも検証しましたが、
>さっぱり上手く集計されませんよ。
>
>>  dataFolder = "C:\Documents and Settings\月間データ統合"
>
>こういうところからして、おかしいかなと。

何か変ですか?

上記の部分は、元々のコード

Application.ScreenUpdating = False
dataFolder = "C:\Documents and Settings\月間データ統合" 'データフォルダ
Set tmpSheet = Sheets("Sheet1") '作業シート
tmpSheet.Cells.Clear '作業シートクリア

から持ってきているので、フォルダの確認は取っていません
正規のフォルダに修正して下さい

尚、まだ、出力ファイルのファイル名が違っている様です

        '出力ファイルをOpen
'        fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
        fileName = dataFolder & "\" & vntFileNames(r - 1, 1) & ".csv" '★修正

【63933】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 19:40 -

引用なし
パスワード
   こんにちは。かみちゃん です。

▼Hirofumi さん:

>何か変ですか?
>
>上記の部分は、元々のコード

なるほど。そういうことですか。それは失礼しました。

ただ、[63924]で、Csvのサンプルと、結果のサンプルが出ているのですが、
何度も修正されるのであれば、そのコードでいいのかなぁというのが、本当の思いです。

勝手にコードをお借りして、[63929]で、サンプル提示しましたけど。

【63934】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 09/12/31(木) 20:14 -

引用なし
パスワード
   ▼つよぽん さん:

>もう少し細かくお伝えすると、統合フォルダの中に20091201フォルダ、20091202フォルダと日付フォルダがあり、
>日付フォルダの中には1001csv、1002csv、1003csvと1400の店舗データがあります。

お疲れ様です...

いまフォルダの構成は

統合フォルダ
 ┗━━20091201
     1001.csv
     1002.csv
     1003.csv
     1004.csv
      :
     2400.csv

 ┗━━20091202
     1001.csv
     1002.csv
     1003.csv
     1004.csv
      :
     2400.csv

 ┗━━20091203
     1001.csv
     1002.csv
     1003.csv
     1004.csv
      :
     2400.csv

ということのようですけど、
(毎日整理していくのだからそういう構成になったのかも
知れませんが、)

店舗別統合という処理からすると、
店舗別に1か月分のcsvの入ったサブフォルダがあると
店舗ごとに片付けていくことができるので
処理しやすかったですね。
(結果論ですけど)

店舗別200912フォルダ
 ┗━━1001
      1001-1201.csv
      1001-1202.csv
      1001-1203.csv
      :
 ┗━━1002
      1002-1201.csv
      1002-1202.csv
      1002-1203.csv
      :
 ┗━━1003
      1003-1201.csv
      1003-1202.csv
      1003-1203.csv
      :
 ┗━━1004
      1004-1201.csv
      1004-1202.csv
      1004-1203.csv
      :

【63935】Re:マクロを早く快適に動かしたいです
発言  Hirofumi  - 09/12/31(木) 20:33 -

引用なし
パスワード
   >ただ、[63924]で、Csvのサンプルと、結果のサンプルが出ているのですが、
>何度も修正されるのであれば、そのコードでいいのかなぁというのが、本当の思いです。

どう言う意味ですか?

【63936】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 21:01 -

引用なし
パスワード
   こんにちは。かみちゃん です。

▼Hirofumi さん:
>>ただ、[63924]で、Csvのサンプルと、結果のサンプルが出ているのですが、
>>何度も修正されるのであれば、そのコードでいいのかなぁというのが、本当の思いです。
>
>どう言う意味ですか?

大変失礼しました。
改めて、質問を読み直したところ、私の大きな勘違いでした。

> これを1400店舗でそれぞれ商品ごとの1ヶ月の販売個数を統合したい

という要件から

> 店舗毎の1ヶ月の商品の総数を統合したcsvを作りたい

という要望を読み解けませんでした。

そして、改めて、
[63927]のコード(出力ファイル名は修正しました)を検証させていただいたところ、
私は、OKではないかと思います。

そして、私が勝手に借りた[63929]と[63931]のコードは、要件に合っていないということになります。
大変申し訳ありませんでした。

ただ、今回ご提示いただいたコードは、とてもよい勉強になりましたので、今後生かしていきたいと思います。

【63937】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 21:04 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>データはかみちゃんさんのご想像通りです。
>
>  時間   商品名   商品数
>というタイトル行は、なく、
>
>>と店舗毎の1ヶ月の商品の総数を統合した
>
>ものをCSVファイルではなく、ワークシート上に出力するのでよければ、
>Hirofumiさんのコードをお借りすると以下のような感じで集計できると思います。

私、大きな勘違いしていました。
提示しましたコードは、店舗毎に集計されませんので、間違っています。
[63927]でHirofumiさんが提案されたコードで、できると思います。
こちらで用意したサンプルデータで確認しました。

【63938】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 09/12/31(木) 22:54 -

引用なし
パスワード
   ▼つよぽん さん:

>もう少し細かくお伝えすると、統合フォルダの中に20091201フォルダ、20091202フォルダと日付フォルダがあり、
>日付フォルダの中には1001csv、1002csv、1003csvと1400の店舗データがあります。

遅ればせながら、、、
統合する店舗の数だけ Dictionary配列に 統合テーブル作成して
最後にまとめて ファイル出力するサンプルです。

このサンプルを試すためには
★ VBEメニュ−[ツール]-[参照設定]より
  Microsoft Scripting Runtime に参照設定しておいてください

Sub Try1()
 Dim dataFolder As String
 Dim subFolder() As String, subCount As Long
 Dim fo
 Dim fileName As String
 Dim i As Long
 Dim dic() As Dictionary

 dataFolder = "C:\Documents and Settings\月間データ統合\" 'データフォルダ
 
 'データフォルダ内のサブフォルダ名を取得
 fileName = Dir$(dataFolder & "*.*", vbDirectory)
 Do While Len(fileName)
  If (GetAttr(dataFolder & fileName) And vbDirectory) = vbDirectory Then
   If Not (fileName Like ".*") Then ' サブフォルダならば
     subCount = subCount + 1
     ReDim Preserve subFolder(1 To subCount)
     subFolder(subCount) = dataFolder & fileName & "\"
   End If
  End If
  fileName = Dir$() '次のフォルダ名を取得
 Loop
 
 Dim 店舗名 As String
 Dim nDic As Long
 Dim n As Long
 ReDim dic(1500)
 Set dic(0) = New Dictionary
 For Each fo In subFolder
   fileName = Dir$(fo & "*.csv")
   While Len(fileName) '(ある日付の)店舗名.csv 取得
     店舗名 = Left$(fileName, InStrRev(fileName, ".") - 1)
     If Not dic(0).Exists(店舗名) Then
       nDic = nDic + 1
       n = nDic
       dic(0).Item(店舗名) = n
       Set dic(n) = New Dictionary
     Else
       n = dic(0).Item(店舗名)
     End If
     '------------
     csv統合 fo & fileName, dic(n) '商品コード別集計
     '------------
     fileName = Dir$()
   Wend
 Next
 
 '店舗別 統合ファイル出力
 Dim 店舗, 商品 As String
 Dim vv
 Dim io As Integer
 Application.ScreenUpdating = False
 io = FreeFile()
 For Each 店舗 In dic(0).Keys()
   n = dic(0).Item(店舗)
   With ThisWorkbook.Worksheets(1)
     .Cells(1).Resize(dic(n).Count, 2).Value = _
      Application.Transpose(Array(dic(n).Keys, dic(n).Items))
     .UsedRange.Sort Key1:=.Columns(1), Header:=xlNo
     vv = .UsedRange.Value
     .UsedRange.ClearContents
   End With
   fileName = dataFolder & 店舗 & ".csv"
   Open fileName For Output As io
   For i = 1 To UBound(vv)
     Print #io, Join(Array(vv(i, 1), vv(i, 1), vv(i, 2)), ",")
   Next
   Close io
 Next
 Application.ScreenUpdating = True
 Erase dic
 MsgBox nDic & "店舗の 統合が完了しました"
   
End Sub

'★ 指定のCSVファイルを開き、商品別に数量集計
Private Sub csv統合(myCSV As String, tbl As Dictionary)
  Dim io As Integer
  Dim buf() As Byte
  io = FreeFile()
  Open myCSV For Binary As io
  ReDim buf(1 To LOF(io))
  Get #io, , buf
  Close io
  
  Dim vv, v
  Dim i As Long
  vv = Split(StrConv(buf, vbUnicode), vbCrLf)
  For i = 0 To UBound(vv) - 1
    v = Split(vv(i), ",")
    tbl(v(1)) = tbl(v(1)) + Val(v(2)) '統合
  Next '      商品   数量
  
End Sub

【63939】Re:マクロを早く快適に動かしたいです
質問  つよぽん  - 10/1/1(金) 18:32 -

引用なし
パスワード
   サンプルVBA試しました。ありがとうございます。
めちゃくちゃ早いです。15時間掛かっていたのが5分でした。

計算もチェックしましたがピッタリです。

非常に感謝しております。

最後に一点だけ教えてください。
というのは、CSVファイルの名前と内容が一つづつずれるのです。
100、101、102のCSVファイルを作ろうとすると
100は作成されず、101、102と名無しのCSVが作成され、
101には100の内容が、102には101の内容が、名無しには102の内容が保存されます。
どこをどう訂正すればいいのですか?よろしくお願いします。

【63940】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 10/1/1(金) 18:39 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>CSVファイルの名前と内容が一つづつずれるのです。
>100、101、102のCSVファイルを作ろうとすると
>100は作成されず、101、102と名無しのCSVが作成され、
>101には100の内容が、102には101の内容が、名無しには102の内容が保存されます。
>どこをどう訂正すればいいのですか?よろしくお願いします。

[63932]でHirofumiさんより訂正コメントが出ていますが、ご確認いただけていますか?

【63941】Re:マクロを早く快適に動かしたいです
発言  つよぽん  - 10/1/1(金) 18:57 -

引用なし
パスワード
   kanabunさんサンプルマクロありがとうございます。
皆さんに助けていただき多いに感謝しております。

サンプルマクロ試しました。
色々試したのですが、マクロ自体解読できない私には・・なぜディバックなのかわかりません。
下記のところで、ファイルが見つからないとエラーが出るのです。
 If (GetAttr(dataFolder & fileName) And vbDirectory) = vbDirectory Then

うーん。あっ・・頭から煙が・・・

【63942】Re:マクロを早く快適に動かしたいです
お礼  つよぽん  - 10/1/1(金) 19:16 -

引用なし
パスワード
   確認いたしました。見落としてました。
最後までありがとうございました。

かみちゃんさんにとって良いお年でありますように・・・

【63943】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 10/1/1(金) 19:41 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>下記のところで、ファイルが見つからないとエラーが出るのです。
> If (GetAttr(dataFolder & fileName) And vbDirectory) = vbDirectory Then

dataFolder = "C:\Documents and Settings\月間データ統合\" 'データフォルダ
                           ^^^
変数dataFolderの末尾は、"\" になっていますか?
つよぽんさんが最初に提示されたコードやHirofumiさんのコードと違って、
末尾が"\" になっている必要があると思います。

【63944】Re:マクロを早く快適に動かしたいです
発言  Yuki  - 10/1/2(土) 10:46 -

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

もう、解決されていられるようですが
遅らせながら、サンプルです。そこそこ早いです。


Public Sub TestFileConvert()
  Dim v1   As Variant
  Dim v2   As Variant
  Dim v3()  As String
  Dim buf()  As Byte
  Dim strDir As String
  Dim sF()  As String
  Dim i    As Long
  Dim j    As Long
  Dim strYm  As String
  Dim IO   As Integer
  Dim Dic   As Object
  Dim strKy  As Variant
  Dim strKy1 As String
  Dim sK   As String
  Dim flg   As Boolean
  Dim tt
  
  tt = Timer
 
  strYm = "200912"    ' 処理月
  strDir = "C:\Documents and Settings\月間データ統合\"    'データフォルダ最後に\

  sF = GetFiles(strDir, strYm)
  If Sgn(sF) = 0 Then Exit Sub
  ' 縦横逆用
  ShelSortStrA sF(), UBound(sF, 2) + 1, 1
  
  Set Dic = CreateObject("Scripting.Dictionary")
  ReDim Preserve sF(1, UBound(sF, 2) + 1)
  For i = LBound(sF, 2) To UBound(sF, 2) + 1
    If i = UBound(sF, 2) Then flg = True
    If sK = "" Then
      sK = sF(0, i)
    Else
      If sK <> sF(0, i) Then
        v1 = Dic.Keys
        v2 = Dic.Items
        Dic.RemoveAll
        ReDim v3(1, UBound(v1))
        For j = 0 To UBound(v1)
          v3(0, j) = v1(j)
          v3(1, j) = v2(j)
        Next
        ShelSortStrA v3(), UBound(v3, 2) + 1, 1
        IO = FreeFile
        Open strDir & sK For Output As #IO
          Print #IO, "商品CD, 数量"
          For j = 0 To UBound(v3, 2)
            Print #IO, v3(0, j) & "," & v3(1, j)
          Next
        Close #IO
        sK = sF(0, i)
      End If
      If flg Then Exit For
    End If
    DoEvents
    IO = FreeFile
    Open sF(1, i) & sF(0, i) For Binary Lock Read As #IO
      ReDim buf(LOF(IO) - 3)
      Get #IO, , buf
    Close #IO
    v1 = Split(StrConv(buf, vbUnicode), vbCrLf)
    For j = 0 To UBound(v1)                          '1行めがタイトルaの時は 1 から
      v2 = Split(v1(j), ",")
      Dic(v2(1)) = Dic(v2(1)) + CLng(v2(2))
    Next
  Next
  Debug.Print Timer - tt
End Sub

Private Function GetFiles(ByVal Path As String, YM As String) As String()
  Dim sDir  As String
  Dim sD()  As String
  Dim sFile  As String
  Dim sF()  As String
  Dim i    As Long
  Dim j    As Long
  Dim sDt   As String
  Dim eDt   As String
  
  sDt = YM & "01"
  eDt = Format(DateAdd("d", -1, DateAdd("m", 1, _
         CDate(Format(sDt, "0000/00/00")))), "yyyymmdd")
  sDir = Dir(Path, vbDirectory)
  Do While sDir <> ""
    If sDir <> "." And sDir <> ".." Then
      If (GetAttr(Path & sDir) And vbDirectory) = vbDirectory Then
        If sDir >= sDt And sDir <= eDt Then
          ReDim Preserve sD(i)
          sD(i) = Path & sDir & "\"
          i = i + 1
        End If
      End If
    End If
    sDir = Dir
  Loop
  
  For i = LBound(sD) To UBound(sD)
    sFile = Dir(sD(i) & "*.csv")
    Do While sFile <> ""
      ReDim Preserve sF(1, j)
      sF(0, j) = sFile
      sF(1, j) = sD(i)
      j = j + 1
      sFile = Dir()
    Loop
  Next
  GetFiles = sF()
End Function


'**************************** ShelSortStrA 引数 *********************
'  data() データ
'  Count  要素の数
'  Sort  1 = 昇順, -1 = 降順
'*********************************************************************
Public Sub ShelSortStrA(data() As String, Count As Long, Sort As Long)
  Dim ix   As Long
  Dim iy   As Long
  Dim iz   As Long
  Dim strTemp As String
  Dim temp1  As Variant
  Dim temp2  As Variant
  Dim gap   As Long
  
  gap = Count \ 2
  Do While gap > 0
    iz = 0
    Do While iz < gap
      iy = iz + gap
      Do While iy < Count
        ix = iy - gap
        Do While ix >= iz
          If StrComp(data(0, ix), data(0, ix + gap), 1) = Sort Then
            temp1 = data(0, ix + gap)
            temp2 = data(1, ix + gap)
            data(0, ix + gap) = data(0, ix)
            data(1, ix + gap) = data(1, ix)
            data(0, ix) = temp1
            data(1, ix) = temp2
          Else
            Exit Do
          End If
          ix = ix - gap
        Loop
        iy = iy + gap
      Loop
      iz = iz + 1
    Loop
    gap = gap \ 2
  Loop
End Sub

【63945】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 10/1/2(土) 11:11 -

引用なし
パスワード
   こんにちは。かみちゃん です。

▼Yuki さん:
>遅らせながら、サンプルです。そこそこ早いです。

[63924]で、つよぽんさんは、以下のような結果を求めておられるようです。

-----
   商品名  商品名  商品数
1  100101  100101    1001ヶ月の販売数
2  100105  100105    800
3  102001  102001    100
と店舗毎の1ヶ月の商品の総数を統合したcsvを作りたい
-----

タイトル行が必要かどうかはよくわかりませんが、
商品名(商品CD)は、2列分必要なようです。

 Print #IO, v3(0, j) & "," & v3(1, j)
の部分を
 Print #IO, v3(0, j) & "," & v3(0, j) & "," v3(1, j)
とすればいいのかもしれませんが・・・

【63948】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 10/1/2(土) 22:23 -

引用なし
パスワード
   ▼つよぽん さん、皆さん:
あけましておめでとうございます。


さて、質問者さんのほうでは解決されたようで何よりですが、

>めちゃくちゃ早いです。15時間掛かっていたのが5分でした。

この
> 5分
というのはどのようなデータについてのことでしょうか?

というのも、年明けて、試しに
▼20日分のサブフォルダ、400店舗に制限して 提示された
 3つのサンプルを実行したところ、
Hirofumiさんの
 Sub 月間データ統合_4()   760.9秒 (約 12.7分)
kanabunの
 Sub Try1()         174.6秒 (約3分)
Yukiさんの
 Sub TestFileConvert()   219.4秒 (約3.65分)
でした。

1400店舗もあれば、どのコードを使っても 単純に比例計算しても
5分で終わることはできないと思うのですが。。。

ちょっと気になりました。
正月早々、解決後すみませんm(_ _)m

今年もよろしく!

【63949】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 10/1/2(土) 23:21 -

引用なし
パスワード
   上の Try1() はメモリを贅沢に使用していました。
店舗が1400 あれば 1400個のDictionaryを同時使用していました。
1400ものDictionaryを使って統合処理すると、メモリが圧迫されて
実用にならないかもしれません。

で、
店舗別ファイルリストを先に作成して、リスト順にひとつづつ
店舗別統合を行うように改造してみました。

例によって
> VBEメニュ−[ツール]-[参照設定]より
> Microsoft Scripting Runtime に参照設定しておいてください

Sub Try2()  
 Dim dataFolder As String
 Dim subFolder() As String, subCount As Long
 Dim fo
 Dim fileName As String
 Dim i As Long
 Dim t!

 t = Timer()
 'dataFolder = "C:\Documents and Settings\月間データ統合\" 'データフォルダ
 dataFolder = "D:\(Data)\temp月間データ統合\" 'データフォルダ
 If Right$(dataFolder, 1) <> "\" Then dataFolder = dataFolder & "\"
 
 'データフォルダ内のサブフォルダ名を取得
 ReDim subFolder(1 To 40)       '40日分
 fileName = Dir$(dataFolder & "*.*", vbDirectory)
 Do While Len(fileName)
  If (GetAttr(dataFolder & fileName) And vbDirectory) = vbDirectory Then
   If Not (fileName Like ".*") Then ' サブフォルダならば
     subCount = subCount + 1
     subFolder(subCount) = dataFolder & fileName & "\"
   End If '               (\20091201 のような)
  End If
  fileName = Dir$() '次のフォルダ名を取得
 Loop
 ReDim Preserve subFolder(1 To subCount) '実在するSubFolder
 
 '店舗別 ファイルリストを作成
 Dim Dic As Dictionary
 Dim nDic As Long
 Dim 店舗名 As String
 Dim n As Long
 Set Dic = New Dictionary
 For Each fo In subFolder
   fileName = Dir$(fo & "*.csv")
   While Len(fileName) '(ある日付のFolder内の) 店舗名.csv 取得
     店舗名 = Left$(fileName, InStrRev(fileName, ".") - 1)
     If Not Dic.Exists(店舗名) Then nDic = nDic + 1
     Dic(店舗名) = Dic(店舗名) & "," & _
      Replace(fo, dataFolder, "", Compare:=vbTextCompare) & fileName
     fileName = Dir$()    '次のCSVファイル名
   Wend
 Next
 
 '店舗別 集計 統合ファイル出力
 Dim 店舗
 Dim vv, v
 Dim io As Integer
 Dim buf() As Byte
 Dim myCSV
 Dim tbl As Dictionary    '商品別統合用テーブル
 Application.ScreenUpdating = False
 io = FreeFile()
 For Each 店舗 In Dic.Keys()
   Set tbl = New Dictionary 'テーブル初期化
   For Each myCSV In Split(Mid$(Dic(店舗), 2), ",")
     '指定のCSVファイルを開き、商品別に数量集計
     Open dataFolder & myCSV For Binary As io
     ReDim buf(1 To LOF(io))
     Get #io, , buf
     Close io
     vv = Split(StrConv(buf, vbUnicode), vbCrLf)
     Set tbl = New Dictionary
     For i = 0 To UBound(vv) - 1
       v = Split(vv(i), ",")
       tbl(v(1)) = tbl(v(1)) + Val(v(2)) '統合
     Next '      商品   数量
   Next
   '↑以上である店舗の月間「統合」終了
   '↓商品でソートしてから CSV出力する
   With ThisWorkbook.Worksheets(1)
     .Cells(1).Resize(tbl.Count, 2).Value = _
      Application.Transpose(Array(tbl.Keys, tbl.Items))
     .UsedRange.Sort Key1:=.Columns(1), Header:=xlNo
     vv = .UsedRange.Value
     .UsedRange.ClearContents
   End With
   ReDim v(1 To UBound(vv))
   For i = 1 To UBound(vv)
     v(i) = Join(Array(vv(i, 1), vv(i, 1), vv(i, 2)), ",")
   Next
   fileName = dataFolder & 店舗 & ".csv"
   Open fileName For Output As io
     Print #io, Join(v, vbCrLf)
   Close io
   Set tbl = Nothing
 Next
 Application.ScreenUpdating = True
 Set Dic = Nothing
 Debug.Print "'Try2", Timer() - t
 MsgBox nDic & "店舗の 統合が完了しました"
   
End Sub

実行Speedは 先ほどと同じデータ↓
> 20フォルダ(20日) 400店舗(各フォルダ内に 400のCsvファイル)
 (ひとつのCSVファイルは 約5000行です)

で、Try1とほぼ同じでした。

  Try2     167秒 (約 3分)

【63950】Re:マクロを早く快適に動かしたいです
発言  kanabun  - 10/1/2(土) 23:29 -

引用なし
パスワード
   すみません。間違い発見

 For Each 店舗 In Dic.Keys()
   Set tbl = New Dictionary 'テーブル初期化
   For Each myCSV In Split(Mid$(Dic(店舗), 2), ",")
     '指定のCSVファイルを開き、商品別に数量集計
     Open dataFolder & myCSV For Binary As io
     ReDim buf(1 To LOF(io))
     Get #io, , buf
     Close io
     vv = Split(StrConv(buf, vbUnicode), vbCrLf)
     'Set tbl = New Dictionary  ←←←←←←←← ★この行 不要です
     For i = 0 To UBound(vv) - 1
       v = Split(vv(i), ",")
       tbl(v(1)) = tbl(v(1)) + Val(v(2)) '統合
     Next '      商品   数量
   Next
   '↑以上である店舗の月間「統合」終了
   '↓商品でソートしてから CSV出力する

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