VBA ワークシートを別ブックにコピーする

呼び出し元プロシージャ

Sub シート操作テスト()

Dim ORG_Path As String              'コピー元ブックパス
Dim DST_Path As String              'コピー先ブックパス
Dim ORG_wb As Workbook              'コピー元ブック
Dim DST_wb As Workbook              'コピー先ブック
Dim arr_ORG_Sheets() As String      'コピー元ブックのワークシート名全てを格納した配列
Dim i As Integer

'各ブックパスを格納
ORG_Path = "C:\Users\デスクトップ\ExcelVBAプロジェクト\シート取得\コピー元.xlsx"
DST_Path = "C:\Users\デスクトップ\ExcelVBAプロジェクト\シート取得\コピー先.xlsx"

'コピー元ブックのシート名をまとめて取得
arr_ORG_Sheets = fncGetSheets(ORG_Path)

'コピー元とコピー先のbookを開く
Set ORG_wb = Workbooks.Open(ORG_Path)
Set DST_wb = Workbooks.Open(DST_Path)

'コピー元bookのワークシートをコピー先ブックへコピー

For i = 0 To UBound(arr_ORG_Sheets)
    Call sub_AddSheet(ORG_wb, DST_wb, "After", arr_ORG_Sheets(i))
Next

End Sub

シートコピー部品

Sub sub_AddSheet(ORG_wb As Workbook, DST_wb As Workbook, _
                     strAddPosition As String, strAddSheetName As String)
'--------------------------------------------------------------------------
'機能：指定されたブックの指定されたシートをコピー先ブックの指定された位置にコピーする
'引数１：コピー元ブック
'引数２：コピー先ブック
'引数３：コピー位置（Before または After または追加位置の数値を文字列で指定)
'引数４：コピー対象のシート名
'--------------------------------------------------------------------------
    Dim cnt As Long
    
    'コピー元ブックの対象ワークシートを選択
    ORG_wb.Sheets(strAddSheetName).Activate
    
   'シートのコピー位置を判定して指定の場所にコピー
    If strAddPosition = "Before" Then
        ActiveSheet.Copy Before:=DST_wb.Sheets(1)
        
    ElseIf IsNumeric(strAddPosition) Then
        With DST_wb
            cnt = CInt(strAddPosition)
            ActiveSheet.Copy _
            After:=.Sheets(cnt - 1)
        End With
        
    Else
        With DST_wb
            ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
        End With
    End If
    
End Sub

シート取得部品

Function fncGetSheets(strFilePath As String) As String()
'----------------------------------------------------------
'機　能：指定してファイルパス内のシート名を取得し配列にして返す
'引　数：対象ファイルパス
'戻り値：シート名の配列
'----------------------------------------------------------
    Dim objCn As Object
    Dim objRs As Object
    'Dim strFile As String
    Dim sSheet As String
    Dim i As Long
    Dim arrSheets() As String
'----------------------------------------------------------
    Set objCn = CreateObject("ADODB.Connection")
    Set objRs = CreateObject("ADODB.Recordset")
    
    With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0"
        .Open strFilePath
        'ADODBを遅延バインディングしているためOpanSchemaの
        '定数「adSchemaTables」を値の「20」で指定する
        Set objRs = .OpenSchema(20)
    End With
   '--------------------------------------------------------
    i = 1
    Do Until objRs.EOF
        ReDim Preserve arrSheets(i - 1)
        sSheet = objRs.Fields("TABLE_NAME").Value
        If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then
            If Right(sSheet, 1) = "$" Then
                sSheet = Left(sSheet, Len(sSheet) - 1)
            End If
            If Right(sSheet, 2) = "$'" Then
                sSheet = Left(sSheet, Len(sSheet) - 2)
            End If
            If Left(sSheet, 1) = "'" Then
                sSheet = Mid(sSheet, 2)
            End If
            sSheet = Replace(sSheet, "''", "'")
            arrSheets(i - 1) = sSheet
            i = i + 1
        End If
        objRs.MoveNext
    Loop
    objRs.Close
    objCn.Close
    Set objRs = Nothing
    Set objCn = Nothing
    fncGetSheets = arrSheets
End Function