CODEWITHSUNDEEP
excelvba
John C. Osborn
John C. Osborn

Reputation: 23

Merge Multiple Rows Macro

I need a MACRO that looks at all instances of COL A and combines all values of COL B into one row, while deleting the duplicates in the process. Adding a comma is a plus.

Example of what I need:

COL A    COL B 
100 ---- PC 245
100 ---- PC 246
100 ---- PC 247
101 ---- PC 245
101 ---- PC 246
101 ---- PC 247

INTO

COL A    COL B 
100 ---- PC 245, PC 246, PC 247
101 ---- PC 245, PC 246, PC 247

This data is going into a map, so I need it concatenated for the tooltip text.

PS: What I need is a MACRO. What I don't need is a PIVOT TABLE.

Upvotes: 2

Views: 6640

Answers (2)

nutsch
nutsch

Reputation: 5962

Sub ConsolidateRows()
'takes rows and consolidate one or many cells, based on one or many cells matching with above or below rows.

Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant

'**********PARAMETERS TO UPDATE****************
Const strMatch As String = "A"    'columns that need to match for consolidation, separated by commas
Const strConcat As String = "B"     'columns that need consolidating, separated by commas
Const strSep As String = ", "     'string that will separate the consolidated values
'*************END PARAMETERS*******************

application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

colMatch = Split(strMatch, ",")
colConcat = Split(strConcat, ",")

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 2 Step -1 'loop from last Row to one
    
    For j = 0 To UBound(colMatch)
        If Cells(i, colMatch(j)) <> Cells(i - 1, colMatch(j)) Then GoTo nxti
    Next
    
    For j = 0 To UBound(colConcat)
        Cells(i - 1, colConcat(j)) = Cells(i - 1, colConcat(j)) & strSep & Cells(i, colConcat(j))
    Next
    
    Rows(i).Delete
    
nxti:
Next

application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub

Upvotes: 4

NickSlash
NickSlash

Reputation: 5100

The following code requires you to add a reference to "Microsoft Scripting Runtime".

VBA Editor->Tools->References, Find and select Microsoft Scripting Runtime

Its possible to use "Collections" instead of "Dictionarys". I just prefer the dictionary.

The code will read the active worksheet, (the "Do Loop") and copies the data (removing duplicates in the process)

It then clears all data on the sheet.

It then loops through the data it collected and outputs it to the now empty worksheet (the "For Each" loops)

Sub Cat()
Dim Data As Dictionary
Dim Sheet As Worksheet

Set Sheet = ThisWorkbook.ActiveSheet
Set Data = New Dictionary

Dim Row As Integer
Dim Key As Variant
Dim Keys() As Variant
Dim Value As Variant
Dim Values() As Variant
Dim List As String

Row = 1

Do
    If Data.Exists(CStr(Sheet.Cells(Row, 1))) Then
        If Not Data(CStr(Sheet.Cells(Row, 1))).Exists(CStr(Sheet.Cells(Row, 2))) Then
            Data(CStr(Sheet.Cells(Row, 1))).Add (CStr(Sheet.Cells(Row, 2))), True
        End If
    Else
        Data.Add CStr(Sheet.Cells(Row, 1)), New Dictionary
        Data(CStr(Sheet.Cells(Row, 1))).Add (CStr(Sheet.Cells(Row, 2))), True
    End If
    Row = Row + 1
    If IsEmpty(Sheet.Cells(Row, 1)) Then
        Exit Do
    End If
Loop

Sheet.Cells.ClearContents

Keys = Data.Keys
Row = 1

For Each Key In Keys
    Values = Data(Key).Keys
    Sheet.Cells(Row, 1) = Key
    List = ""
    For Each Value In Values
        If List = "" Then
            List = Value
        Else
            List = List & ", " & Value
        End If
    Next Value
    Sheet.Cells(Row, 2) = List
    Row = Row + 1
Next Key

End Sub

Upvotes: 0

Related Questions