ExcelVBA 特定フォルダ複数ブック特定シートを1ブックにコピーし集約する

はじめに

同一内容が記載されたExcelファイルが多数存在する。
当該ファイルはシート１に内容が記載されているが
集計するために、1シートに集約したい。
コピペの手作業だと絶望的な数だったのでVBAで対応しました。

↓こんな感じのファイル

作業内容

新規ブックを作成して
以下のマクロを記述して実行した。

Sub 特定フォルダ複数ブック特定シートを1ブックにコピーし集約する()
On Error GoTo Exception

    Dim MyBookName      'カレントブック名
    Dim buf As String   'ファイル一覧取得
    Dim cnt As Long     'カウント
    Dim Path As String                'ワークブックパス
    Dim Paste_des_Colum As Long     '貼り付け先の列
    Dim Last_Row As Long              '貼り付け先の行
    Dim Paste_source_Cell As String   '貼り付け元の開始セル

    MyBookName = ActiveWorkbook.Name
    Paste_des_Colum = 2
    Paste_source_Cell = "A2"
    
    'ワークブックパスを取得
    Path = ThisWorkbook.Path & "\"
        
    'ワークブック読み取り
    buf = Dir(Path & "*.xlsx")
    
    Do While buf <> ""
        
        '貼り付け先の最終行を取得する
        Last_Row = Range("B65535").End(xlUp).Row
        
        'ブック開く
        Workbooks.Open Path & buf
        'ブック選択
        Windows(buf).Activate
        'シート選択
        Sheets("Sheet1").Select
        '表の最終まで範囲選択
        Range(Range(Paste_source_Cell), ActiveCell.SpecialCells(xlLastCell)).Select
        'コピー
        Selection.Copy
        
        'ブック戻す
        Windows(MyBookName).Activate
        Sheets("Sheet1").Select
        'コピー先選択
        Cells(Last_Row + 1, Paste_des_Colum).Select
        '貼り付け
        ActiveSheet.Paste
        
         'ブック閉じる
        Windows(buf).Close
                
        cnt = cnt + 1
        buf = Dir()
    Loop

    MsgBox "終了しました"

Exception:
    MsgBox Err.Number & vbCrLf & Err.Description
    
End Sub

---

履歴

2021/10/3 新規作成