Aggregate, Collate and Transpose rows into columns
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
Solution 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.
Solution 2:
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.