子育てエンジニアブログ

子育てに励むシステムエンジニア(SE)のブログ

【VBA】複数のファイル複数のシートを1つにまとめるVBA

複数のファイル複数のシートを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