Macro: Group ColA with ColB results

Closed
Report
Posts
1
Registration date
Thursday April 8, 2010
Status
Member
Last seen
April 8, 2010
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Im trying to build a macro to produce the expected results below.

I have duplicate tests in ColA with associated data in ColB:
I need to merge the test names in ColA and list all ColB associated data in ColB

ColA ColB
Test 1 100555
Test 2 100555
Test 1 100550
Test 1 100556

Expected:
ColA ColB
Test 1 100555, 100550, 100556
Test 2 100555

Any assisatance would be greatly appreciated,
Thanks,
Corey

1 reply

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Objective:
To consolidate the data by grouping a column and transposing its corresponding values across various column in one row.

Assumptions:
1. The data is on sheet1
2. The data to be grouped is in column A
3. The data that is to transposed or moved across various columns is in B
4. Columns after column B are available


Steps:
1. Read the Assumptions
2. Make a back up copy
3. Press ALT + F11 to get into VBE and insert a new module
4. Paste the code below in the module


Code:
Sub transposeSpecial()
Dim dataSheet As String
Dim lMaxRows As Long
Dim currRow As Long
Dim temp As String

    dataSheet = "Sheet1"
    
    Sheets(dataSheet).Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        
        On Error Resume Next
        
        ActiveSheet.ShowAllData
        
        On Error GoTo 0
    
    End If
    
    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
    
    currRow = 2
    Do While Cells(currRow, "A") <> ""
        
        temp = Cells(currRow, "A")
        
        If ActiveSheet.AutoFilterMode = False Then
            Cells.Select
            Selection.AutoFilter
        End If
    
        Selection.AutoFilter Field:=1, Criteria1:="=" & temp
    
        lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
        
        If lMaxRows > 1 Then
        
            Range("B" & (currRow + 1) & ":B" & lMaxRows).Copy
            
            Range("C" & currRow).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            
            
            Rows(currRow + 1 & ":" & lMaxRows).Delete
        End If
        
        currRow = currRow + 1
        
    Loop
    
    If ActiveSheet.AutoFilterMode = False Then
        Cells.Select
        Selection.AutoFilter
    End If
    
End Sub