Transpose Excel column to rows

Question

I have an Excel sheet that looks like the first picture and I want to convert it to the second picture:

I have written the following code but it does not work as ex

Answer 1

My take on this problem .

Sub test()

    Dim lCtrRow_Raw     As Long
    Dim lCtrRow_New     As Long
    Dim lInst           As Long

    Dim dctUniq         As New Dictionary
    Dim sKey
    Dim arrRaw
    Dim arrNew()

    '/ Specify your range here. Only two columns of data should be used.
    arrRaw = Selection() ' ****Avoid using Selection in actual code****.

    '/ Filter Duplicates.
    For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
        If Not dctUniq.Exists(arrRaw(lCtrRow_Raw, 1)) Then
            dctUniq.Add arrRaw(lCtrRow_Raw, 1), arrRaw(lCtrRow_Raw, 1)
        End If
    Next

    '/ Start New Array
    ReDim arrNew(1 To dctUniq.Count, 1 To 1)

    '/ Seed IDs
    For Each sKey In dctUniq.Keys
        lCtrRow_New = lCtrRow_New + 1
        arrNew(lCtrRow_New, 1) = dctUniq(sKey)
    Next

    '/ Loop and assign unique values
    For lCtrRow_New = LBound(arrNew) To UBound(arrNew)
      lInst = 1
     For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
            If arrRaw(lCtrRow_Raw, 1) = arrNew(lCtrRow_New, 1) Then
                lInst = lInst + 1
                If lInst > UBound(arrNew, 2) Then
                    ReDim Preserve arrNew(1 To dctUniq.Count, 1 To lInst)
                End If

                arrNew(lCtrRow_New, lInst) = arrRaw(lCtrRow_Raw, 2)
            End If
       Next
    Next

    '/ Dump array in the data sheet.
    'Sheet1.Range("A20").Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value = arrNew
End Sub