Transpose Data Using Macro

Try the attached

Sub test()
    Dim r As Range, i As Long, x As String
    Application.ScreenUpdating = False
    With Cells(1).CurrentRegion.Resize(, 3).Columns(1)
        .Offset(, 4).Resize(, 2).Clear
        For Each r In .SpecialCells(2)
            r(1, 2).Resize(, 2).Copy r.Offset(, 4)
        Next
        For Each r In .SpecialCells(4).Areas
            For i = 1 To 2
                x = r(0).Offset(, i).Resize(r.Count + 1).Address
                r(0, 4 + i).Value = Join(Filter(Evaluate("transpose(if(" & _
                        x & "<>""""," & x & ",char(2)))"), Chr(2), 0), ",")
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub