エクセル２００３

書式や数式の設定用にひな形となるシートを使うようにしました。
「SheetD」という名前のシートを作り、A6:BK6に罫線と各セルの書式のほか、A6にはナンバリング用に「=ROW(A6)-5」を、BG6:BH6にはそれぞれ計算式を入れておいてください。
それが各行にコピーされます。
あと、SheetCが無ければ自動的作ります。その際、SheetDの内容をコピーしますので、SheetDのA4:BK5にタイトルを入れておけばコピーされます。

Option Explicit

Sub Macro1()
    ' データ対象範囲を指定
    ' 変更があれば修正してください
    Const sheetNameA = "SheetA" ' シートAの名前
    Const sheetNameB = "SheetB" ' シートBの名前
    Const sheetNameC = "SheetC" ' シートCの名前
    Const sheetNameD = "SheetD" ' 書式シートの名前
    Const startRowA = 6 ' シートAの開始行
    Const startRowB = 2 ' シートBの開始行
    Const startRowC = startRowA ' シートCの開始行
    Const startRowD = startRowA ' 書式シートの開始行
    Const indexColA = "M" ' シートAのナンバー列
    Const indexColB = "F" ' シートBのナンバー列
    Const indexColC = indexColA ' シートCのナンバー列
    '
    ' データコピーを行う範囲の設定値
    ' 書式シートからシートCへデータをコピーする範囲の設定(数式も含めて)
    Dim fromD As Variant
    fromD = Array("A:BK", "A") ' 書式シートのA:BKをシートCのAからの範囲へ行う
    '
    ' シートAからシートCへデータをコピーする範囲（書式も含めて）
    Dim fromA As Variant
    fromA = Array("B:BK", "B") ' シートAのB:BKをシートCのBからの範囲へ行う
    '
    ' シートBからシートCへデータをコピーする範囲(これは複数からなる)
    ' シートBのA:EをシートCのBからの範囲へ行う、など
    Dim fromB As Variant
    fromB = Array( _
        Array("A:E", "B"), _
        Array("F:H", "M"), _
        Array("I", "AZ"), _
        Array("J:N", "BB"), _
        Array("O:Q", "BI"))
    '
    Dim endRowA As Long
    Dim endRowB As Long
    Dim endRowC As Long
    Dim indexA As Range
    Dim indexB As Range
    Dim sheetA As Worksheet
    Dim sheetB As Worksheet
    Dim sheetC As Worksheet
    Dim sheetD As Worksheet
    Dim i As Long
    Dim j As Long
    Dim res As Object
    ' それぞれのシート
    Set sheetA = Worksheets(sheetNameA)
    Set sheetB = Worksheets(sheetNameB)
    Set sheetD = Worksheets(sheetNameD)
    ' シートAとシートBの最終行を求める
    endRowA = sheetA.Cells(sheetA.Rows.Count, indexColA).End(xlUp).Row
    endRowB = sheetB.Cells(sheetB.Rows.Count, indexColA).End(xlUp).Row
    ' シートCのデータの追加行-1
    endRowC = startRowC - 1
    
    ' シートCの存在確認
    For Each sheetC In Worksheets
        If sheetC.Name = sheetNameC Then Exit For
    Next sheetC
    ' シートCが無ければ作る
    If sheetC Is Nothing Then
        Set sheetC = Worksheets.Add(Type:=xlWorksheet)
        sheetC.Name = sheetNameC
        ' 書式シートから表題部分をコピーする
        sheetD.Columns(fromD(0)) _
            .Copy Destination:=sheetC.Cells(1, fromD(1))
    End If
    
    ' 画面更新を一時停止
    Application.ScreenUpdating = False
    ' シートBのインデックスとなるナンバーの範囲
    Set indexB = sheetB.Range(sheetB.Cells(startRowB, indexColB), _
                              sheetB.Cells(endRowB, indexColB))
    ' まずシートAの上から順に見ていく
    For i = startRowA To endRowA
        ' シートBから同じナンバーを探す
        Set res = indexB.Find(what:=sheetA.Cells(i, indexColA).Formula, _
            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
        If Not res Is Nothing Then
            ' 見つかったら書式シート、シートA、シートBの値の順でコピーする
            endRowC = endRowC + 1
            sheetD.Columns(fromD(0)).Rows(startRowD) _
                .Copy Destination:=sheetC.Cells(endRowC, fromD(1))
            sheetA.Columns(fromA(0)).Rows(i) _
                .Copy Destination:=sheetC.Cells(endRowC, fromA(1))
            For j = LBound(fromB) To UBound(fromB)
                res.EntireRow.Columns(fromB(j)(0)).Copy
                sheetC.Cells(endRowC, fromB(j)(1)) _
                    .PasteSpecial Paste:=xlPasteValues
            Next j
        End If
    Next i

    ' シートAのインデックスとなるナンバーの範囲
    Set indexA = sheetA.Range(sheetA.Cells(startRowA, indexColA), _
                              sheetA.Cells(endRowA, indexColA))
    ' 次にシートBの上から順に見ていく
    For i = startRowB To endRowB
        ' シートAから同じナンバーを探す
        Set res = indexA.Find(what:=sheetB.Cells(i, indexColB).Formula, _
            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
        If res Is Nothing Then
            ' 見つからなかったら書式シートから数式・書式を含めてコピーした後シートBの値をコピーする
            endRowC = endRowC + 1
            sheetD.Columns(fromD(0)).Rows(startRowD) _
                .Copy Destination:=sheetC.Cells(endRowC, fromD(1))
            For j = LBound(fromB) To UBound(fromB)
                sheetB.Columns(fromB(j)(0)).Rows(i).Copy
                sheetC.Cells(endRowC, fromB(j)(1)) _
                    .PasteSpecial Paste:=xlPasteValues
            Next j
        End If
    Next i
    Application.ScreenUpdating = True
End Sub