離れた複数の列データを貼り付けるプログラム

まずはプログラムの全体

Option Explicit

Sub CopyDataFromWorkbook()
    Dim sourceFilePath As String
    Dim sourceSheetName As String
    Dim destSheetName As String
    Dim pasteStartRow As Long
    Dim pasteStartCol As Long
    Dim srcWb As Workbook, dstWb As Workbook
    Dim srcWs As Worksheet, dstWs As Worksheet
    Dim srcRngArray As Variant
    Dim i As Long
    Dim srcRange As Range
    Dim dataArr As Variant
    
    ' 変数に値を定義
    sourceFilePath = "C:\Users\YourName\Desktop\source.xlsx"
    sourceSheetName = "Sheet1"
    destSheetName = "Sheet1"
    pasteStartRow = 5
    pasteStartCol = 2
    ' コピーする範囲リスト
    srcRngArray = Array("A1:A10", "C1:C10")
    
    ' コピー元のブックを開く
    Set srcWb = OpenWorkbook(sourceFilePath)
    If srcWb Is Nothing Then Exit Sub
    
    ' コピー元のシートを取得
    Set srcWs = srcWb.Sheets(sourceSheetName)
    
    ' 貼り付け先のブック・シートを取得
    Set dstWb = ThisWorkbook
    Set dstWs = dstWb.Sheets(destSheetName)
    
    ' 各範囲を一括コピー
    For i = LBound(srcRngArray) To UBound(srcRngArray)
        ' コピー元の範囲を取得
        Set srcRange = srcWs.Range(srcRngArray(i))
        
        ' データを配列に格納して一括貼り付け
        dataArr = srcRange.Value
        dstWs.Cells(pasteStartRow, pasteStartCol + i). _
                Resize(UBound(dataArr, 1), UBound(dataArr, 2)).Value = dataArr
    Next i
    
    ' コピー元のブックを閉じる（保存しない）
    srcWb.Close False
    
    ' 完了メッセージ
    MsgBox "コピーが完了しました。", vbInformation
    
End Sub

' ブックを開く関数
Function OpenWorkbook(filePath As String) As Workbook
    Dim wb As Workbook
    
    On Error Resume Next
    Set wb = Workbooks.Open(filePath)
    On Error GoTo 0
    
    ' 開けなかった場合の処理
    If wb Is Nothing Then
        MsgBox "指定されたファイルを開けませんでした：" & vbCrLf & filePath, vbExclamation
    End If
    
    Set OpenWorkbook = wb
End Function

1．変数を宣言

    Dim sourceFilePath As String
    Dim sourceSheetName As String
    Dim destSheetName As String
    Dim pasteStartRow As Long
    Dim pasteStartCol As Long
    Dim srcWb As Workbook, dstWb As Workbook
    Dim srcWs As Worksheet, dstWs As Worksheet
    Dim srcRngArray As Variant
    Dim i As Long
    Dim srcRange As Range
    Dim dataArr As Variant

rngArray → コピーする範囲を 配列 で管理（例: Array("A1:A10", "C1:C10")）

2．変数に値を設定

    sourceFilePath = "C:\Users\YourName\Desktop\source.xlsx"
    sourceSheetName = "Sheet1"
    destSheetName = "Sheet1"
    pasteStartRow = 5
    pasteStartCol = 2
    srcRngArray = Array("A1:A10", "C1:C10")

貼り付けるシートの開始 行 (pasteStartRow) と 列 (pasteStartCol) を設定。
srcRngArray にコピーしたい範囲を格納。

3．コピー元のエクセルを開く

    Set srcWb = OpenWorkbook(sourceFilePath)
    If srcWb Is Nothing Then Exit Sub

OpenWorkbook() 関数（後述）を使って、コピー元のブックを開く。
開けなかった場合 (Nothing の場合) は 処理を終了する。

4．コピー元のシートを取得

    Set srcWs = srcWb.Sheets(sourceSheetName)

sourceSheetName に指定したシートを取得。

5．貼り付け先のシートを取得

    Set dstWb = ThisWorkbook
    Set dstWs = dstWb.Sheets(destSheetName)

ThisWorkbook → 今開いているExcelブック。
destSheetName のシートを取得。

6．指定範囲をループし、データをコピー

    For i = LBound(srcRngArray) To UBound(srcRngArray)
        ' コピー元の範囲を取得
        Set srcRange = srcWs.Range(srcRngArray(i))
        
        ' データを配列に格納して一括貼り付け
        dataArr = srcRange.Value
        dstWs.Cells(pasteStartRow, pasteStartCol + i). _
                Resize(UBound(dataArr, 1), UBound(dataArr, 2)).Value = dataArr
    Next i

For ループで 範囲ごとにデータをコピー。
srcRange.Value で セルの値を取得し、配列 (dataArr) に格納。
dstWs.Range(...).Value = dataArr で 一括貼り付け。
貼り付け位置は pasteStartCol + i でずらす。

7．コピー元のブックを閉じる

srcWb.Close False

False を指定 → 変更を保存せずに閉じる。

8．完了メッセージを表示

MsgBox "コピーが完了しました。", vbInformation

9．ブックを開く関数　OpenWorkbook()

Function OpenWorkbook(filePath As String) As Workbook
    Dim wb As Workbook
    
    On Error Resume Next
    Set wb = Workbooks.Open(filePath)
    On Error GoTo 0
    
    ' 開けなかった場合の処理
    If wb Is Nothing Then
        MsgBox "指定されたファイルを開けませんでした：" & vbCrLf & filePath, vbExclamation
    End If
    
    Set OpenWorkbook = wb
End Function

ファイルを開く処理を関数化。
エラーが発生した場合は Nothing を返す。