VBA 複数ファイルの操作

質問

初心者のため教えてください m(__)m

現在VBAにて処理を簡単にしたいと考えております
やりたいことは、同一フォルダ「TEST」に20個ほど.xlsxファイルがあります。
そのそれぞれのブックにはシートが４つに分かれており「data」という
シートのA3～AU3のデータを集約.xlsmの「まとめ」というシートに転記したいです。
また、
・追記するされる際に一番左側（A）には番号を自動で振りたい。（1.2.3.4.....）
・データはB2から貼り付け、最終行にどんどん追記されるようにしたい
・ファイルを開かずに実行したい
・最後に転記完了のメッセージを出したい

いろいろとサイトで調べているのですがなかなか進まず助けて頂けると幸いです。

よろしくお願いいたします

回答No.1

NuboChan · ベストアンサー

未検証なので参考ですが
このコードを実行すると、集約.xlsmの「まとめ」というシートに、TESTフォルダ内の複数のブックの「data」というシートのA3～AU3のデータが、番号付きで追記されるはずです。

集約.xlsmの「メイン」というシートの1-２列に、以下のようにパラメータを入力します。
対象フォルダ シート名 　データ範囲 集約開始行
　TEST 　　　　　data 　　A3:AU3 　2

Sub test()
Dim shtMain As Worksheet 'メインシート
Dim shtSummary As Worksheet '集約シート
Dim folderPath As String '対象フォルダ
Dim shtName As String 'シート名
Dim dataRange As String 'データ範囲
Dim startRow As Long '集約開始行
Dim fso As Object 'FileSystemObject
Dim f As Object 'ファイル
Dim wb As Workbook '対象ブック
Dim ws As Worksheet '対象シート
Dim lastRow As Long '最終行
Dim nextRow As Long '次の行
Dim no As Long '番号

'メインシートを変数に格納
Set shtMain = ThisWorkbook.Sheets("メイン")

'集約シートを変数に格納
Set shtSummary = ThisWorkbook.Sheets("まとめ")

'パラメータを変数に格納
folderPath = shtMain.Range("A2")
shtName = shtMain.Range("B2")
dataRange = shtMain.Range("C2")
startRow = shtMain.Range("D2")

'集約シートの開始行以下をクリア
shtSummary.Rows(startRow & ":" & shtSummary.Rows.Count).Clear

'FileSystemObjectを変数に格納
Set fso = CreateObject("Scripting.FileSystemObject")

'対象フォルダに存在するファイル数分処理
For Each f In fso.GetFolder(folderPath).Files
'ファイルの拡張子がxlsxの場合
If fso.GetExtensionName(f.Name) = "xlsx" Then
'対象ブックを開く
Set wb = Workbooks.Open(f.Path, False, True)
'対象シートを変数に格納
Set ws = wb.Sheets(shtName)
'集約シートの最終行を取得
lastRow = shtSummary.Cells(shtSummary.Rows.Count, 1).End(xlUp).Row
'次の行を計算
If lastRow < startRow Then
nextRow = startRow
Else
nextRow = lastRow + 1
End If
'番号を計算
no = nextRow - startRow + 1
'番号を集約シートに書き込む
shtSummary.Cells(nextRow, 1) = no
'データを集約シートにコピー
ws.Range(dataRange).Copy shtSummary.Cells(nextRow, 2)
'対象ブックを閉じる
wb.Close False
End If
Next f

'メモリを解放
Set fso = Nothing
Set wb = Nothing
Set ws = Nothing

'転記完了のメッセージを出す
MsgBox "転記が完了しました。", vbInformation, "Copilot"

End Sub

お礼

まだ動かしていないのですが、ここまでコードを書いて頂き感謝いたします！

Powered by GRATICA