I want to merge rows based on multiple columns by VBA.

I have a table like below:

Expected Result

What have tried:

I thought to use Dictionary and ArrayList, but Dictionary can not have multiple keys, and for ArrayList, I am able to save first table to arraylist, but, can not decide how to create the second based on arraylist.

Sub CompressTable(source As Range, target As Range, condition As Range, value As Range)
    Dim objList As Object
    Dim objRow()
    Set objList = CreateObject("System.Collections.ArrayList")
    For r = 1 To source.Rows.Count
        For c = 1 To source.Columns.Count
            If r = 1 Then
                ' add header
                target.Offset(r - 1, c - 1) = source.Cells(r, c)
            Else
                ' not sure how to check whether the col1   col2 exist
                target.Offset(r - 1, c - 1) = source.Cells(r, c)
            End If
        Next c
    Next r
    
End Sub

More details image

CodePudding user response：

Please, try the next code. It uses arrays and a dictionary and it should be very fast. It is based on the unique keys, built by concatenation of Col1 and Col2. The code as it is, returns in the next sheet. You should adapt the code to return where you want/need:

Sub CompressTable()
 Dim sh As Worksheet, shRet As Worksheet, lastR As Long, lastCol As Long, dict As Object
 Dim arr, arrH, arrFin, arrItem, a, i As Long, j As Long, k As Long, strColVal As String

 Set sh = ActiveSheet 'use here the sheet to be processed
 Set shRet = sh.Next  'use here the sheet where the result to be returned

 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row          'last row
 lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column
 arr = sh.Range("A1", sh.cells(lastR, lastCol)).value 'place the range in an array, for faster iteration
 arrH = sh.Range("A1", sh.cells(1, lastCol)).value    'place the headers in an array

 'fill the dictionary for unique keys and items built as concatenation between column number and its value
 Set dict = CreateObject("Scripting.Dictionary")
 For i = 2 To UBound(arr)
    For j = 3 To lastCol
        If arr(i, j) <> "" Then strColVal = j & ";" & arr(i, j)
    Next j
    dict(arr(i, 1) & "|" & arr(i, 2)) = dict(arr(i, 1) & "|" & arr(i, 2)) & "|" & strColVal
 Next
 ReDim arrFin(1 To dict.count   1, 1 To lastCol): k = 1 'redim the aray to keep the final result and initialize K
 'Place the header in the array
 For i = 1 To UBound(arrH, 2): arrFin(k, i) = arrH(1, i): Next i: k = k   1
 'process the dictionary keys and items:
 For i = 0 To dict.count - 1
    arrFin(k, 1) = Split(dict.Keys()(i), "|")(0): arrFin(k, 2) = Split(dict.Keys()(i), "|")(1)
    arrItem = Split(dict.items()(i), "|")
    For j = 1 To UBound(arrItem)
        a = Split(arrItem(j), ";")
        arrFin(k, CLng(a(0))) = CLng(a(1))
    Next j
    k = k   1
 Next
 'drop the final array content at once:
 shRet.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
 shRet.Activate
 MsgBox "Ready...)"
End Sub

If you really need to expand Co1 to Col2 range, to build the unique keys, you can try that only using relevant headers name and change a little the code logic, in order to use so built keys and iterate starting after the last column used for building a key...

CodePudding user response：

As I said in the comments, consider using Pivot Tables (and probably you can do it this way with VBA too).

Create Pivot Table and then:

1. Take your criteria columns (in example, Col1 and Col2) into rows section
2. Take your Values (Col3 and Col4) into Values section and choose Sum Function
3. Remove subtotals, grand totals and apply tabular design.

IT takes seconds and it will return the output you are looking for. And if you got Excel 2010 or higher you can add an extra option, repeat item labels so there will be not blanks in Col1:

So, the code won't work if the "source" table dynamically always change. For example, later on the table is changed to something like this :

If the "source" table is always fixed, but the image you attached is just for example (2 columns to be matched, another 2 columns for the value), then the code is still can be modified.