エクセル２００３

Option Explicit

Sub Macro1()
    ' データ対象範囲を指定
    ' 終了行は後で求める
    Const startCol = "A"
    Const indexCol = "G"
    Const endCol = "AU"
    Const startRow = 4
    Dim endRowA As Long
    Dim endRowB As Long
    Dim nowRowC As Long
    Dim indexA As Range
    Dim indexB As Range
    Dim sheetA As Worksheet
    Dim sheetB As Worksheet
    Dim sheetC As Worksheet
    Dim i As Long
    Dim res As Object
    ' それぞれのシートを指定
    Set sheetA = Worksheets("SheetA")
    Set sheetB = Worksheets("SheetB")
    Set sheetC = Worksheets("SheetC")
    ' シートAとシートBの最終行を求める
    endRowA = sheetA.Cells(sheetA.Rows.Count, indexCol).End(xlUp).Row
    endRowB = sheetB.Cells(sheetB.Rows.Count, indexCol).End(xlUp).Row
    ' シートCのデータの追加行
    nowRowC = startRow
    ' シートAとシートBのインデックスとなるナンバーの範囲
    Set indexA = sheetA.Range(sheetA.Cells(startRow, indexCol), sheetA.Cells(endRowA, indexCol))
    Set indexB = sheetB.Range(sheetB.Cells(startRow, indexCol), sheetB.Cells(endRowB, indexCol))
    
    ' まずシートAの上から順に見ていく
    For i = startRow To endRowA
        ' シートBから同じナンバーを探す
        Set res = indexB.Find(what:=sheetA.Cells(i, indexCol).Value, _
            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
        ' 見つかったらシートCにコピーする
        If Not res Is Nothing Then
            sheetB.Range(sheetB.Cells(res.Row, startCol), sheetB.Cells(res.Row, endCol)) _
                .Copy Destination:=sheetC.Cells(nowRowC, startCol)
            nowRowC = nowRowC + 1
        End If
    Next i
    ' 次にシートBの上から順に見ていく
    For i = startRow To endRowB
        ' シートAから同じナンバーを探す
        Set res = indexA.Find(what:=sheetB.Cells(i, indexCol).Value, _
            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
        ' 見つからなかったらシートCにコピーする
        If res Is Nothing Then
            sheetB.Range(sheetB.Cells(i, startCol), sheetB.Cells(i, endCol)) _
                .Copy Destination:=sheetC.Cells(nowRowC, startCol)
            nowRowC = nowRowC + 1
        End If
    Next i
End Sub

こんなところでいかがでしょうか。