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 conditi

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