Sub test()
    myTransp Range("A1:A9"), Range("B1:B9"), Range("C1")
End Sub

Public Sub myTransp(input1 As Range, input2 As Range, outputRange As Range)
    Dim arr As Variant
    arr = input1.Value
    
    Dim brr As Variant
    brr = input2.Cells(1, 1).Resize(UBound(arr, 1)).Value
    
    Dim orr As Variant
    orr = GetOutputArray(arr, brr)
    If IsEmpty(orr) Then Exit Sub
    
    outputRange.Resize(UBound(orr, 1), UBound(orr, 2)).Value = orr
End Sub

Private Function GetOutputArray(arr As Variant, brr As Variant)
    Dim dic As Object
    Set dic = GetMainDic(arr, brr)
    If dic.Count = 0 Then Exit Function
    
    Dim nCol As Long
    nCol = GetColumnNumber(dic)
    If nCol = 0 Then Exit Function
    
    Dim orr As Variant
    ReDim orr(1 To dic.Count, 1 To 1 + nCol)
    
    FillArr orr, dic
    GetOutputArray = orr
End Function

Private Sub FillArr(arr As Variant, dic As Object)
    Dim ya As Long
    Dim xa As Long
    Dim vv As Variant
    Dim ww As Variant
    For Each vv In dic.Keys()
        ya = ya + 1
        xa = 1
        arr(ya, 1) = vv
        For Each ww In dic(vv).Keys()
            xa = xa + 1
            arr(ya, xa) = ww
        Next
    Next
End Sub

Private Function GetColumnNumber(dic As Object) As Long
    Dim nn As Long
    Dim mm As Long
    Dim vv As Variant
    For Each vv In dic.Items
        mm = vv.Count
        If nn < mm Then nn = mm
    Next
    GetColumnNumber = nn
End Function

Private Function GetMainDic(arr As Variant, brr As Variant)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim bic As Object
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not dic.Exists(arr(ya, 1)) Then
            Set dic(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
        End If
        Set bic = dic(arr(ya, 1))
        bic(brr(ya, 1)) = Empty
        Set dic(arr(ya, 1)) = bic
        Set bic = Nothing
    Next
    arr = Empty
    brr = Empty
    Set GetMainDic = dic
End Function