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

	A	　B	　C	　D	　E	　F	　G
1　　顧客番号	名前	年月	入力日	金額１	金額２	金額３
2	101	あ	202404				
3	101	あ	202405				
4	101	あ	202406				
5	101	あ	202407				
6	104	え	202404				
7	104	え	202405				
8	104	え	202406				
9	104	え	202407				
10	107	き	202404				
11	107	き	202405				
12	107	き	202406				
13	107	き	202407	


			
2．Bｼｰﾄ・・・入力データ								

	A	B      C    　E	　　　　D	F	 G	 H
1　　顧客番号  名前  漢字名 入力日 　　年月	金額１	金額２	金額３
2	101	あ     亜  2024/6/10   202405    1	 4	 5
3	101	あ     亜  2024/9/30   202406    2	 5	 7
4	107	き     着  2024/6/30   202404		 2	
5	107	き     着  2024/12/21  202407	 3		 8
6								
7								
8								


3．Aｼｰﾄ(記入元）・・・書き込み後							
 
     A       B	  C	 D	    E	   F	 G
1  顧客番号 名前  年月	入力日	  金額１ 金額２	金額３
2  101	    あ	 202404				
3  101	    あ	 202405	2024/6/10   1	   4	  5
4  101	    あ	 202406	2024/9/30   2	   5	  7
5  101	    あ	 202407				
6  104	    え	 202404				
7  104	    え	 202405				
8  104	    え	 202406				
9  104	    え	 202407				
10 107	    き	 202404	2024/6/30	   2	
11 107	    き	 202405				
12 107	    き	 202406				
13 107	    き	 202407	2024/12/21   3		  8
						 	

説明内容							
ＡＡシート（書き込み前台帳）にＢシートキーとなる顧客番号・年月のデータが
あれば							
それぞれ該当の行・列に入力日・金額１・金額２・金額３を貼付したいです							
							
例として書き込み後は　3．Aｼｰﾄ　のようになります							

どなたか上記のようなＶＢＡ（コーディング）について							
ご教示頂ければ幸いです							
よろしくお願いいたします　　（ＷＩＮＤＯＷＳ11です）						

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

＞Ａシートの顧客番号は実際には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