VBA script to concatenate a cell value based on two columns

Question

I'm very new to VBA and just now started to automate things in excel. I have a requirement to concatenate a cell value based on two columns. For example

In the above excel, in the A column if Doc2 exists thrice, but it has levels of 3,4 & 3 (in row number 3,4, &6 respectively). I want to concatenate values of the id into a single column like below

Based on level and Document Name, if both are same then concatenate id else do not.

Sub ConcatenateCellsIfSameValueExists()
DestRowRef = 2
CheckedCell = Cells(2, "A").Value
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row + 1
    If Cells(i, "A").Value <> CheckedCell Then
        tempConValues = tempConValues
        Cells(DestRowRef, "C").Value = tempConValues
        tempConValues = ""
        DestRowRef = DestRowRef + 1
    End If
    tempConValues = tempConValues & " " & Cells(i, "B").Value
    CheckedCell = Cells(i, "A").Value
Next
End Sub

I tried the above code, it only concatenates based on single-cell and also, repeated Document name once concatenated is not deleted. Can anyone please help here?

Ron Rosenfeld Ron Rosenfeld · Accepted Answer · 2021-05-30T09:44:59

In VBA I would use a Dictionary to organize the data. For a key, concatenate what you want to group (DocumentName and Level) and for the contents the concatenated ID's.

'Set Reference to Microsoft Scripting Runtime
Option Explicit
Sub jugate()
'Declare variables
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim D As Dictionary
    Dim I As Long, V As Variant
    Dim sKey As String
    
'set Source and Result worksheets and ranges
Set wsSrc = ThisWorkbook.Worksheets("sheet4") 'edit to real worksheet
Set wsRes = ThisWorkbook.Worksheets("sheet4") 'could put this on different sheet
    Set rRes = wsRes.Cells(1, 6)
    
'read table into array for fastest processing
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With

'read into dictionary, combining like doc/level
Set D = New Dictionary
    D.CompareMode = TextCompare
    
For I = 2 To UBound(vSrc) 'skip header row
    sKey = vSrc(I, 1) & "|" & vSrc(I, 3)
    If Not D.Exists(sKey) Then
        D.Add Key:=sKey, Item:=vSrc(I, 2)
    Else
        D(sKey) = D(sKey) & vbLf & vSrc(I, 2)
    End If
Next I

'create results array
ReDim vRes(0 To D.Count, 1 To 3)

'header row
For I = 1 To 3
    vRes(0, I) = vSrc(1, I)
Next I

'populate data
I = 0
For Each V In D.Keys
    I = I + 1
    vRes(I, 1) = Split(V, "|")(0) 'doc name
    vRes(I, 2) = D(V) 'concatenated ID
    vRes(I, 3) = Split(V, "|")(1) 'level
Next V

'write results to worksheet
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes

'Next lines are just for formatting
'not really necessary and not internationally aware
    .Style = "output"
    .EntireColumn.AutoFit
    .VerticalAlignment = xlCenter
End With

End Sub

You can also obtain your desired output using Power Query, available in Windows Excel 2010+ and Office 365 Excel

Select some cell in your original table
Data => Get&Transform => From Table/Range
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps
After Close/Load, format the resultant table for Word Wrap and centering.
- This formatting should persist through subsequent refreshes.

M Code

let

//Change table name in next line to your actual table name
    Source = Excel.CurrentWorkbook(){[Name="Table11"]}[Content],

//set data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{
        {"DocumentName", type text}, {"ID", type text}, {"Level", Int64.Type}}),

//group by doc name and Level
//then aggregate the text strings
    #"Grouped Rows" = Table.Group(#"Changed Type", {"DocumentName", "Level"}, {
        {"ID", each List.Accumulate([ID],"",
            (state,current)=> if state = "" then current else state & "#(lf)" & current), Text.Type}
        }),

//Place columns in desired order
    #"Reordered Columns" = Table.ReorderColumns(#"Grouped Rows",{"DocumentName", "ID", "Level"})
in
    #"Reordered Columns"

VBA script to concatenate a cell value based on two columns

1 Answers