CODEWITHSUNDEEP
excelrowscellsvba
Jan
Jan

Reputation: 43

Excel VBA to merge data from multiple rows

I have a quite big XLS with information spread over multiple rows that looks like:

TopName   Name   Mode   Item1   Item2   Item3   Item4
-----------------------------------------------------
Foo       Name1  ModeX  x()
Foo       Name2  ModeY                  x()
Foo       Name1  ModeX                  y() 
Foo       Name1  ModeX                          y()
Foo       Name2  ModeY  y()

What I now want to do is merge the data based on the name into a new sheet or Excel file. The output table should look something like

Name   Mode   Item1   Item2   Item3   Item4
-------------------------------------------
Name1  ModeX  x()             y()     y()
Name2  ModeY  y()             x()

I myself will try to come up with a solution via VBA, but there is surely somebody who is way better in that and can maybe post a simple solution?

Update: I tried the following but it does not work at all:

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 = "B"    'columns that need to match for consolidation, separated by commas
Const strConcat As String = "C,D,F,H,I,J,K,L,M,N,O,P,Q,R,S,T,U"     '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("B" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 4 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

Update2: OK, the file does not even have two matching values in consecutive rows and thus, the code above can obviously not work :( What I need is some kind of dictionary or something...

Upvotes: 1

Views: 2398

Answers (1)

Alexander Bell
Alexander Bell

Reputation: 7918

Pertinent to your task and sample Excel Worksheet data shown below:

TopName Name    Mode    Item1   Item2   Item3   Item4

Foo     Name1   ModeX   x()         
Foo     Name2   ModeY                    x()    
Foo     Name1   ModeX                    y()    
Foo     Name1   ModeX                          y()
Foo     Name2   ModeY   y()

you can use the following Excel VBA code snippet:

Sub ConsolidateRowsData()
Dim lastRow As Long, i As Long, j As Long, k As Long

Application.ScreenUpdating = False 'disable ScreenUpdating

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

'concatenate Item data
For i = 3 To lastRow  'outer loop thru data rows (starting w/row 3)
    For j = i + 1 To lastRow 'inner loop thru data rows
        If Cells(i, 2) = Cells(j, 2) Then
            For k = 4 To 7 'loop thru columns: Item1...Item4
                If (Cells(i, k) = "" And Cells(j, k) <> "") Then
                    Cells(i, k) = Cells(j, k)
                End If
            Next
        End If
    Next
Next

'delete duplicates
For i = 3 To lastRow   'outer loop thru data rows
    For j = lastRow To i + 1 Step -1 'inner loop thru data rows
        If Cells(i, 2) = Cells(j, 2) Then
            Rows(j).Delete
        End If
    Next
Next

Application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub

Even though it's not optimized for speed, but will do the job. Hope this will help. Best regards,

Upvotes: 1

Related Questions