VBA Code - Copy and Transpose paste with specific conditions

Question

I have written a code which copies data (in a row) from Sheet3 and transpose paste into COLUMN c in Sheet2 However, I need to break the rows copied and pasted based on a condition that the ID in Sheet2 Column A1 TO A4000 matches Columns D1 TO D4000.

Looping through the rows in Sheet3 and pasting it by filling it to the right i.e. transpose.

For example:

SHEET 3:
1 202  Anna
2 202  Mary
3 202  Gary
4 204 France
5 204  Greece
6 301 London
7 301 Alice
8 301 Mandy
9 406 HongKong
10 406 Osaka

Should be Pasted into Sheet 2 As:

   A    B      C       D
1 202 Anna    Mary    Gary
2 204 France  Greece
3 301 London  Alice   Mandy

Here's my current code:

Dim Sourcerange  As Range
Dim Targetrange As Range


Set Sourcerange = Sheet3.Range("N3:N4105")
Set Targetrange = Sheet2.Range("C1:C4105")

Sourcerange.Copy
Targetrange.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, _
            Transpose:=True

End Sub

I will like to loop through the rows without having to change the sourcerange or target range from the code.

Answer 1

Here one of the solutions

Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key

x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
For Each CLa In Sheets("Sheet3").Range("A1:A" & x)
    If Not Dic.exists(CStr(CLa.Value)) Then
        ID = CLa.Value

        For Each CLb In Sheets("Sheet3").Range("A1:A" & x)
            If CLb.Value = ID Then

                If Names = "" Then
                    Names = CLb.Offset(, 1).Value
                Else
                    Names = Names & "," & CLb.Offset(, 1).Value
                End If

            End If
        Next CLb

    Dic.Add ID, Names
    End If
    ID = Empty: Names = Empty
Next CLa

x = 1
For Each Key In Dic
    Sheets("Sheet2").Cells(x, 1).Value = Key
    Sheets("Sheet2").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",")
    x = x + 1
Next Key

Sheets("Sheet2").Cells.Replace "#N/A", Replacement:=""

End Sub

Source sheet3

Output sheet2