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
    
1001    A
1001    H
1001    H
1001    H
1001    B
    
1001    A
1001    H
1001    H
1001    H
1001    B
    
1001    B
1001    H
1001    H
1001    H
1001    B
    
1001    H
    
1001    A
1001    G
1001    H
1001    H
1001    A
1001    B
    
1002    B
1002    H
1002    H
1002    B
    
1002    G
1002    H
    
1002    B
1002    G
1002    G
1002    H
    
1002    B
1002    G
1002    H
1002    H
    
1002    G
1002    H
1002    H
    
1002    H
1002    H
1002    H
1002    M
1002    N
    
1002    G
1002    H
1002    H
1002    M
1002    M
    
1002    A
1002    H
1002    H
1002    H
1002    A
1002    B
    
1002    B
1002    H
1002    H
1002    H
    
1002    B
1002    H
1002    H
1002    H
1002    A
1002    A
    
1002    A
1002    H
1002    H
1002    H
1002    H
1002    B
    
1002    H
    
1003    G
1003    H
1003    H
1003    N
1003    M

And I'm trying to transpose it to make each different id in the first column and all the letters in the second column with one blank space for each blank row in the original table:

1001 AHHH BHHH HHH AHHHB AHHHB BHHHB H AGHHAB
1002 BHHB GH BGGH BGHH GHH HHHMN GHHMM AHHHAB BHHH BHHHAA AHHHHB H
1003 GHHNM

I have about 100 different id. I tried to do with a formula using TRANSPOSE and TRIM. I also tried with a macro and VLOOKUP seems to be the easiest way but can't find out how.

Aeneas

The concatenation of random length groups of values is virtually impossible and certainly impractical. I see VBA as the only realistic avenue to pursue a solution through. – Pentamerous

Answer 1

You cannot concatenate a range of cells (aka Letters) using native worksheet functions without knowing the scope beforehand. As your collection of strings into groups has random numbers of elements, a VBA loop approach seems the best (if not the only) way to address the issue. The loop can make determinations along the way that a worksheet function is simply incapable of performing.

Tap Alt+F11 and when the Visual Basic Editor (aka VBE) opens, immediately use the pull-down menus to Insert ► Module (Alt+I,M). Paste one or both of the following into the new pane titled something like Book1 - Module1 (Code).

To concatenate the string groups delimited by a space:

Sub concatenate_and_transpose_to_delim_string()
    Dim rw As Long, lr As Long, pid As Long, str As String
    Dim bPutInColumns As Boolean

    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).row
        .Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
        pid = .Cells(2, 1).Value
        For rw = 2 To lr
            If IsEmpty(.Cells(rw, 1)) Then
                str = str & Chr(32)
                If pid <> .Cells(rw + 1, 1).Value Then
                    .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
                    .Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
                End If
            ElseIf pid <> .Cells(rw, 1).Value Then
                pid = .Cells(rw, 1).Value
                str = .Cells(rw, 2).Value
            Else
                str = str & .Cells(rw, 2).Value
            End If
        Next rw
        .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
        .Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
    End With
End Sub

To split the string groups into columns:

Sub concatenate_and_transpose_into_columns()
    Dim rw As Long, lr As Long, nr As Long, pid As Long, str As String

    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).row
        .Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
        For rw = 2 To lr
            If IsEmpty(.Cells(rw, 1)) Then
                .Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
                str = vbNullString
            ElseIf pid <> .Cells(rw, 1).Value Then
                pid = .Cells(rw, 1).Value
                nr = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).row
                .Cells(nr, 4) = pid
                str = .Cells(rw, 2).Value
            Else
                str = str & .Cells(rw, 2).Value
            End If
        Next rw
        .Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
    End With
End Sub

Tap Alt+Q to return to your worksheet. With your sample data on the active worksheet starting with Id in A1, tap Alt+F8 to open the Macros dialog and Run the macro.

Results from concatenate_and_transpose_to_delim_string:

    

Results from concatenate_and_transpose_into_columns:

    

The results will be written into the cells starting at D2. Probably best if there was nothing important there beforehand that would be overwritten.

Addendum:

I original misinterpreted your request and split the string groups into separate columns. I've rectified that with a supplemental routine that more closely follows your description of requirements but kept both variations for others to reference.

Pentamerous

Answer 2

Performance in mind. 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.

Sidesman

THANKS A LOT!! Both answers were really perfect I should tick both as useful and give more points to both but don't know how – Aeneas

Thanks :) Just to inform you for future - doing procedures directly in VBE is a lot faster than looping through cells in the worksheet. – Sidesman

The user has posted a new question asking why your macro gives Error 13. It fails when the concatenated cell has a length of 733 characters. My understanding is that WorksheetFunction.Transpose does not work if a element has a length of 255 characters. Certainly, I can clear the error by reducing the length to 255. Note that WorksheetFunction.Transpose is a slow function and ReDim Preserve gets steadily slower so I think you will get a faster routine that does not fail if you output directly to the worksheet. – Remaremain

@Sidesman - I took a stab at overcoming the error reported but wanted to check to see how you would feel about me posting a modification of your sub. Unfortunately, cannot really show you my effort short of posting it as there is no 'sandbox' that I am aware of. – Pentamerous

@Jeeped you can post a modification. I'd be really thankful for that. – Sidesman

@TonyDallimore in my sub I use Application.Transpose instead of WorksheetFunction.Transpose. I don't know the actual difference between them (I think that the one coming from Application should be faster), but, well, they both cause the error 13 as I see. – Sidesman

@Sidesman - I've put it in the new thread here. – Pentamerous

@ZygD. I cannot find anything that states that [Application.]WorksheetFunction.Transpose is different from Application.Transpose although I can find something that implies they are the same. – Remaremain

@Sidesman The experts have always said that Worksheet.Functions are faster than the same functionality coded with VBA. I have recently discovered that this is not true for any of the functions I have timed. For example, two nested for-loops will create a new transposed array over 3 times faster than Transpose. I find it difficult to believe the Excel functions are slow so assume the interface from VBA to an Excel function has a heavy overhead like the interface from VB.Net is Excel. – Remaremain

@Sidesman See Convert 2 dimensional array to one dimensional (without Looping) for more info and a VBA equivalent to Transpose that I assume will not hit the Error 13 limitation.. – Remaremain

@TonyDallimore I would agree that the interface adds the significant overhead. I've read that it's recommended (in relation to performance) to create VBA-created equivalents at least over these worksheet functions: Min(), Max(), Average(), Match(), NormSInv() and StDev(). Thanks for the input! – Sidesman

Answer 3

For tasks like this Microsoft added "Get&Transform" to Excel 2016. In order to use this functionality in earlier versions, you have to use the Power Query Add-In. The M-code is very short:

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    FillIdDown = Table.FillDown(Source,{"Id"}),
    ReplaceNull = Table.ReplaceValue(FillIdDown,null," ",Replacer.ReplaceValue,{"Letter"}),
    Transform = Table.Group(ReplaceNull, {"Id"}, {{"Count", each Text.Combine(_[Letter])}})
in
    Transform

Your data should sit in "Table1". https://www.dropbox.com/s/bnvchofmpvd048v/SO_AggregateCollateAndTransposeColsIntoRows.xlsx?dl=0

Inventor