Combine multiple rows to one row for each ID#

Option Explicit




Sub test()
    Dim a, i As Long, ii As Long, AL As Object
    Set AL = CreateObject("System.Collections.ArrayList")
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            a(i, 1) = StrConv(a(i, 1), vbProperCase)
            If Not AL.Contains(a(i, 1)) Then AL.Add a(i, 1)
            If Not .exists(a(i, 2)) Then
                Set .Item(a(i, 2)) = _
                CreateObject("Scripting.Dictionary")
                .Item(a(i, 2)).CompareMode = 1
            End If
            .Item(a(i, 2))(a(i, 1)) = a(i, 3)
        Next
        AL.Sort
        ReDim a(1 To .Count + 1, 1 To AL.Count + 1)
        a(1, 1) = "ID"
        For i = 0 To AL.Count - 1
            a(1, i + 2) = AL(i)
        Next
        For i = 0 To .Count - 1
            a(i + 2, 1) = .keys()(i)
            For ii = 0 To .items()(i).Count - 1
                a(i + 2, AL.IndexOf(.items()(i).keys()(ii), 0) + 2) = .items()(i).items()(ii)
            Next
        Next
    End With
    With Sheets("sheet2").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a: .Parent.Select
    End With
End Sub

Sub test()
    Dim a, b, i As Long, ii As Long, x, y
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value
        With .Offset(1)
            x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(1).Address & ",,,row(1:" & .Rows.Count & "))," & _
            .Columns(1).Address & ")=1," & .Columns(1).Address & ",char(2)))"), Chr(2), 0)
            y = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(2).Address & ",,,row(1:" & .Rows.Count & "))," & _
            .Columns(2).Address & ")=1," & .Columns(2).Address & ",char(2)))"), Chr(2), 0)
        End With
    End With
    ReDim b(1 To UBound(y) + 2, 1 To UBound(x) + 2)
    For i = 0 To UBound(x)
        b(1, i + 2) = x(i)
    Next
    For i = 0 To UBound(y)
        b(i + 2, 1) = y(i)
        For ii = 2 To UBound(a, 1)
            If CStr(a(ii, 2)) = y(i) Then
                b(i + 2, Application.Match(a(ii, 1), x, 0) + 1) = a(ii, 3)
            End If
        Next
    Next
    With Sheets("sheet2").Cells(1).Resize(UBound(b, 1), UBound(b, 2))
        .CurrentRegion.ClearContents
        .Value = b: .Parent.Select
    End With
End Sub

Sub test()
    Dim a, b(), i As Long, ii As Long, x(), y(), temp1, temp2, flg As Boolean
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: ReDim x(1 To 1), y(1 To 1)
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
        For i = 2 To UBound(a, 1)
            For ii = 2 To UBound(x)
                If x(ii) = a(i, 2) Then
                    flg = True: temp1 = ii: Exit For
                End If
            Next
            If Not flg Then
                ReDim Preserve x(1 To UBound(x) + 1)
                x(UBound(x)) = a(i, 2): temp1 = UBound(x)
                b(temp1, 1) = a(i, 2)
            End If
            flg = False
            For ii = 1 To UBound(y)
                If y(ii) = a(i, 1) Then
                    flg = True: temp2 = ii: Exit For
                End If
            Next
            If Not flg Then
                ReDim Preserve y(1 To UBound(y) + 1)
                y(UBound(y)) = a(i, 1): temp2 = UBound(y)
                b(1, temp2) = a(i, 1)
            End If
            b(temp1, temp2) = a(i, 3)
            flg = False
        Next
    End With
    With Sheets("sheet2").Cells(1).Resize(UBound(x), UBound(y))
        .CurrentRegion.ClearContents
        .Value = b: .Parent.Select
    End With
End Sub