Aggregate, Collate and Transpose rows into columns

Question

I have the following table

 Id     Letter
1001    A
1001    H
1001    H
1001    H

1001    B
1001    H
1001    H
1001    H

1001    H
1001    H
1001    H

10         


        

Answer 1

This option incorporates arrays. From performance point of view, it is much faster to once read data in the worksheet to an array, do your procedures directly in VBE and write the results back to the worksheets as compared to doing procedures in the worksheet cell by cell.

Sub transposing()
Const sDestination As String = "D2"
Dim ar1() As Variant
Dim ar2() As Variant
Dim i As Long 'counter

ar1 = ActiveSheet.Range("A2:B" & ActiveSheet.UsedRange.Rows.Count).Value
ReDim ar2(1 To 1, 1 To 2)
ar2(1, 1) = ar1(1, 1): ar2(1, 2) = ar1(1, 2)
For i = 2 To UBound(ar1, 1)
    If ar1(i, 1) = ar2(UBound(ar2, 1), 1) Then
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
    ElseIf ar1(i, 1) = vbNullString Then
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & " "
    Else
        ar2 = Application.Transpose(ar2)
        ReDim Preserve ar2(1 To 2, 1 To UBound(ar2, 2) + 1)
        ar2 = Application.Transpose(ar2)
        ar2(UBound(ar2, 1), 1) = ar1(i, 1)
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
    End If
Next
ActiveSheet.Range(sDestination).Resize(UBound(ar2, 1), UBound(ar2, 2)).Value = ar2

End Sub

The result will look like this:

The line Const sDestination As String = "D2" states the beginning of the output. Change it to whichever cell you want.