複数のファイル複数のシートを1つにまとめるVBAを今話題のChatGPTに書いてもらった。(一部うまくいかったので修正し、その他も多少修正)
仕様としては、フォルダパスを入力する。
また、A列にはファイルのフルパス、B列にはシート名を入力しC列から内容を記載する。
あまり動作確認していないのでうまくいかないことがあるかも。
Sub CombineSumBooksAndSumSheets() ' 変数定義 Dim folderPath As String Dim fileName As String Dim wbSource As Workbook Dim wsSource As Worksheet Dim wsCombined As Worksheet Dim lastRow As Long Dim combinedRow As Long Dim targetRange As Range Dim sourceRange As Range ' フォルダのパスを入力するダイアログボックスを表示 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください。" .Show If .SelectedItems.Count = 0 Then Exit Sub folderPath = .SelectedItems(1) & "\" End With ' 新しいブックを作成 Set wbSource = Workbooks.Add Set wsCombined = wbSource.Sheets(1) combinedRow = 2 ' フォルダ内のすべてのファイルに対して処理を実行 fileName = Dir(folderPath & "*.xlsx") Do While fileName <> "" ' ファイルを開く Set wbSource = Workbooks.Open(folderPath & fileName) ' ブック内のすべてのシートに対して処理を実行 For Each wsSource In wbSource.Sheets ' シート名を取得 wsCombined.Cells(combinedRow, 1).Value = IIf(wsCombined.Cells(combinedRow - 1, 1) = "", wbSource.FullName, wsCombined.Cells(combinedRow - 1, 1)) wsCombined.Cells(combinedRow, 2).Value = IIf(wsCombined.Cells(combinedRow - 1, 2) = "", wsSource.Name, wsCombined.Cells(combinedRow - 1, 2)) ' シートのデータ範囲を取得 Set sourceRange = wsSource.UsedRange ' データをコピー Set targetRange = wsCombined.Cells(combinedRow, 3) sourceRange.Copy targetRange combinedRow = combinedRow + sourceRange.Rows.Count + 1 ' 1行空ける Next wsSource ' コピーしたシートを閉じる(保存しない) wbSource.Close SaveChanges:=False ' 次のファイルを取得 fileName = Dir Loop ' カラム幅を自動調整する wsCombined.Columns.AutoFit ' A列とB列にデータがない場合は追加 lastRow = wsCombined.Cells(wsCombined.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRow + 1 If wsCombined.Cells(i, 1).Value = "" Then wsCombined.Cells(i, 1).Value = wsCombined.Cells(i - 1, 1).Value End If If wsCombined.Cells(i, 2).Value = "" Then wsCombined.Cells(i, 2).Value = wsCombined.Cells(i - 1, 2).Value End If Next i End Sub