1．Aｼｰﾄ(記入元）・・・書き込み前

例では、金額１，２，３ しかありませんが、この列は今後増えていくのですか？

＞Ａシートの顧客番号は実際には500先ありますので
＞Ａシートの行は　2000＝500Ｘ4（年月）で固定です
そこはちょっと解からないですが、こんなのでいいかもです。

Sub test()
    Dim wsDest As Worksheet
    Dim dicT As Object
    Dim rDest As Range
    Dim aCell As Range
    Dim msg
    Dim RW
    
    Set dicT = CreateObject("Scripting.Dictionary")
    msg = "以下の顧客データは記入先に在りません"
    
    Set wsDest = Worksheets("A") '←実際のシート名にする
    
    With wsDest
        Set rDest = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    
    For Each aCell In rDest 'Dictionaryにキー(番号+年月)とItem(行番号)を登録する
        If aCell.Value <> "" Then
            dicT(aCell & "-" & aCell.Offset(, 2)) = aCell.Row
        End If
    Next
    
    Application.ScreenUpdating = False
    
    With Worksheets("B") '←実際のシート名にする
        
        For Each aCell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
            RW = dicT(aCell & "-" & aCell.Offset(, 4))
            
            If IsNumeric(RW & "") Then
                aCell.Range("D1,F1:H1").Copy wsDest.Cells(RW, "D")
            Else
                msg = msg & vbCrLf & aCell & "-" & aCell.Offset(, 4)
            End If
        Next
    End With
    
    dicT.RemoveAll
    
    Application.ScreenUpdating = True
    
    If InStr(msg, vbCrLf) Then
        MsgBox msg
    End If
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

＞aCell.Range("D1,F1:H1").Copy wsDest.Cells(RW, "D")
　　↓こうかな？(2文に分ける）
  aCell.Range("D1,F1:H1").Copy
  wsDest.Cells(RW, "D").PasteSpecial xlPasteValues