VBAで複数のデータを好きな位置に配置する方法が分からない

Question

### 実現したいこと
VBAで複数のテーブル情報を取得してExcelの一枚のシート上に好きな位置に配置したい

### 発生している問題・分からないこと
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2026-02-10/82466ae5-a2af-414d-838e-572439491af0.png)
一つ目のデータを貼り付けは出来たと思うが、二つ目以降のデータを配置したいが、一つ目のデータの列数が変動すると思うので、その点をカバーできるように二つ目以降のデータを配置をどのようにすればよいか分からない、また三つ目以降は二つ目のデータの右になど様々な位置に配置できる、次に貼り付ける際には元々入っていたデータを削除してフォーマットは残せるように対応させたい

### 該当のソースコード

```VBA
Sub MergeExcelFiles()
    Dim FolderPath As String   'フォルダパス
    Dim Filename As String     'ファイル名
    Dim wbSource As Workbook   '参照テーブルファイル
    Dim wsDest As Worksheet    '貼り付け先シート
    Dim LastRow As Long        '最終行
    Dim PasteRow As Long       '貼り付け行
    Dim wsSource As Worksheet  '参照テーブル格納データ

' まとめ用シートを設定
    Set wsDest = ThisWorkbook.Sheets("まとめ")
    wsDest.Cells.Clear ' 古いデータを削除
    PasteRow = 1

' データが入っているフォルダパスを指定（最後に \ を忘れない）
    FolderPath = "C:\Users\accou\OneDrive\デスクトップ\STAFF_○○\VBA作成テーブル例\" ' ←ここを変更
    Filename = Dir(FolderPath & "*.xlsx") ' フォルダ内のxlsxを取得

' フォルダ内の全ファイルをループ
    Do While Filename <> ""
        Set wbSource = Workbooks.Open(FolderPath & Filename)
        Set wsSource = wbSource.Sheets(1) ' 最初のシートをコピー対象に

' コピーする行数を取得（1列目の最終行）
        LastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

' ヘッダー行を1回だけコピー
        ' If PasteRow = 1 Then
        '     wsSource.Rows(1).Copy wsDest.Rows(PasteRow)
        '     PasteRow = PasteRow + 1
        ' End If

' データ部分をコピー（2行目以降）
        If LastRow > 1 Then
            wsSource.Rows("2:" & LastRow).Copy wsDest.Rows(PasteRow)
            PasteRow = wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Row + 1
        End If

wbSource.Close False
        Filename = Dir ' 次のファイルへ
    Loop

MsgBox "データの統合が完了しました！"
End Sub
```

### 試したこと・調べたこと
- [x] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [x] その他

##### 上記の詳細・結果
FileMakerからExcel用に出力し、フォルダ内に格納された複数のファイルのデータをVBAで自動化し配置できることが分かった。また、そのソースコードが分かった。

### 補足
チャットgptに質問してソースコードを作成しました

Accepted Answer

とりあえず、コメント欄で確認させていただいた内容を踏まえてサンプルマクロを例示します。

- 以下に示す 3 つのブックが全て閉じられている（ Excel 上で開かれていない）状態で実行するものとする。

- 変数`strSourceFolder`にフォルダパスを代入している箇所は適宜書き換えること。

- 各表の貼り付け先は新規ブック上のワークシートとする（事故防止のため）。

- このサンプルでは [UsedRange プロパティ](https://learn.microsoft.com/ja-jp/office/vba/api/excel.worksheet.usedrange)を使用して各表の範囲を参照しているが、あくまでサンプル簡略化のためである。使用に適さない場合もあるので適宜修正すること。

- セル書式の設定は罫線のみに留める。

- 数式セルの設定周りに関しては、詳細が不明なのでここでは割愛する。

### コピー元ブック

- A.xlsx

![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2026-02-12/b70a6e4c-1303-4197-9ca7-b7d637ed9108.png)

- B.xlsx

![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2026-02-12/ee4eea48-b159-4508-9506-c889d835aef4.png)

- C.xlsx

![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2026-02-12/f87c0afa-9723-4cd0-b8df-b5ef49175466.png)

### サンプルマクロ

```vba
Sub CopyTables()
On Error GoTo Err_CopyTables

'画面の再描画処理を無効化
    Application.ScreenUpdating = False
    '数式の再計算方式を「手動」に
    Application.Calculation = xlCalculationManual

'貼り付け先ワークシートに関する事前処理

Dim wsDistination As Worksheet
    Dim rngTarget As Range

'貼り付け先となるワークシートの参照
    '（このサンプルでは新規ブックを作成してその 1 番目のワークシートを参照する）
    Set wsDistination = Workbooks.Add.Worksheets(1)
    
    '貼り付け先ワークシートの操作
    With wsDistination
        'シート名の変更
        .Name = "まとめ"
        '最初の貼り付け先始点セルとして A1 セルを参照する
        Set rngTarget = .Cells(1, 1)
    End With
    
    Dim strSourceFolder As String
    
    'コピー元ブック群が保存されているフォルダの絶対パスを指定
    strSourceFolder = "C:\FolderName\Source\"
    
    Dim wbkSource As Workbook
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim rngDestination As Range
    
'表Aのコピー処理
    
    '表Aのあるブックを読み取り専用で開く
    Set wbkSource = Workbooks.Open(Filename:=strSourceFolder & "A.xlsx", _
                                   ReadOnly:=True)
    '1番目のワークシートを参照する
    Set wsSource = wbkSource.Worksheets(1)
    'そのワークシートの「使用されている領域」を表Aとして参照する
    Set rngSource = wsSource.UsedRange
    
    '表Aをまるごとコピーアンドペースト（値のみコピーではない）
    rngSource.Copy Destination:=rngTarget
    
    '貼り付け先となったセル範囲全体を参照
    Set rngDestination = rngTarget.Resize(RowSize:=rngSource.Rows.Count, _
                                          ColumnSize:=rngSource.Columns.Count)
    
    Debug.Print "コピー元範囲:" & rngSource.Address(External:=True)
    Debug.Print "貼り付け先始点セル:" & rngTarget.Address(External:=True)
    Debug.Print "貼り付け先範囲:" & rngDestination.Address(External:=True)
    
    '罫線の設定
    With rngDestination
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlDot
        .Borders(xlInsideVertical).LineStyle = xlDot
        .Rows(1).Borders(xlEdgeBottom).LineStyle = xlDouble
        .Columns(1).Borders(xlEdgeRight).LineStyle = xlDouble
    End With
    
    Set rngDestination = Nothing
    
    '現在の貼り付け先始点セルから「表Aの行数に 2 を加えた数」だけ下にあるセルを
    '次の貼り付け先始点セルとして参照。
    'これにより、表Aと表Bの間に 2 行分の空白行が出来る
    Set rngTarget = rngTarget.Offset(RowOffset:=rngSource.Rows.Count + 2)

'開いたブックを閉じる
    Set wsSource = Nothing
    wbkSource.Close SaveChanges:=False
    Set wbkSource = Nothing

'表Bのコピー処理

'表Bのあるブックを読み取り専用で開く
    Set wbkSource = Workbooks.Open(Filename:=strSourceFolder & "B.xlsx", _
                                   ReadOnly:=True)
    '1番目のワークシートを参照する
    Set wsSource = wbkSource.Worksheets(1)
    'そのワークシートの「使用されている領域」を表Bとして参照する
    Set rngSource = wsSource.UsedRange

'表Bをまるごとコピーアンドペースト（値のみコピーではない）
    rngSource.Copy Destination:=rngTarget
    
    '貼り付け先となったセル範囲全体を参照
    Set rngDestination = rngTarget.Resize(RowSize:=rngSource.Rows.Count, _
                                          ColumnSize:=rngSource.Columns.Count)

Debug.Print "コピー元範囲:" & rngSource.Address(External:=True)
    Debug.Print "貼り付け先始点セル:" & rngTarget.Address(External:=True)
    Debug.Print "貼り付け先範囲:" & rngDestination.Address(External:=True)
    
    '罫線の設定
    With rngDestination
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlDot
        .Borders(xlInsideVertical).LineStyle = xlDot
        .Rows(1).Borders(xlEdgeBottom).LineStyle = xlDouble
        .Columns(1).Borders(xlEdgeRight).LineStyle = xlDouble
    End With
    
    Set rngDestination = Nothing
    
    '現在の貼り付け先始点セルから「表Bの列数に 2 を加えた数」だけ右にあるセルを
    '次の貼り付け先始点セルとして参照
    'これにより、表Bと表Cの間に 2 列分の空白列が出来る
    Set rngTarget = rngTarget.Offset(ColumnOffset:=rngSource.Columns.Count + 2)

'開いたブックを閉じる
    Set wsSource = Nothing
    wbkSource.Close SaveChanges:=False
    Set wbkSource = Nothing

'表Cのコピー処理

'表Cのあるブックを読み取り専用で開く
    Set wbkSource = Workbooks.Open(Filename:=strSourceFolder & "C.xlsx", _
                                   ReadOnly:=True)
    '1番目のワークシートを参照する
    Set wsSource = wbkSource.Worksheets(1)
    'そのワークシートの「使用されている領域」を表Cとして参照する
    Set rngSource = wsSource.UsedRange

'表Cをまるごとコピーアンドペースト（値のみコピーではない）
    rngSource.Copy Destination:=rngTarget

'貼り付け先となったセル範囲全体を参照
    Set rngDestination = rngTarget.Resize(RowSize:=rngSource.Rows.Count, _
                                          ColumnSize:=rngSource.Columns.Count)
    
    Debug.Print "コピー元範囲:" & rngSource.Address(External:=True)
    Debug.Print "貼り付け先始点セル:" & rngTarget.Address(External:=True)
    Debug.Print "貼り付け先範囲:" & rngDestination.Address(External:=True)
    
    '罫線の設定
    With rngDestination
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlDot
        .Columns(1).Borders(xlEdgeRight).LineStyle = xlDouble
    End With
    
    Set rngDestination = Nothing

'開いたブックを閉じる
    Set wsSource = Nothing
    wbkSource.Close SaveChanges:=False
    Set wbkSource = Nothing

'貼り付け先ワークシートの操作

With wsDistination
        '列幅の自動調整
        .UsedRange.EntireColumn.AutoFit
        'A1 セルを選択
        .Cells(1, 1).Select
        'このワークシートのあるブックをアクティブにする
        .Parent.Activate
    End With

'終了処理
Exit_CopyTables:
On Error Resume Next
    
    '画面の再描画処理を有効化
    Application.ScreenUpdating = True
    '数式の再計算方式を「自動」に
    Application.Calculation = xlCalculationAutomatic
    
    Set rngTarget = Nothing
    Set wsDistination = Nothing
    
    Exit Sub

'エラー時処理
Err_CopyTables:

Dim strErrMsg As String
    
    strErrMsg = Err.Number & ": " & Err.Description

Debug.Print strErrMsg

MsgBox strErrMsg, vbCritical, "実行時エラー (CopyTables)"

Set wsSource = Nothing
    If Not wbkSource Is Nothing Then
        wbkSource.Close SaveChanges:=False
        Set wbkSource = Nothing
    End If

Resume Exit_CopyTables
End Sub
```

### 実行結果
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2026-02-12/b79997b5-5726-4ee7-abe0-74ab81156035.png)