VBA to search for duplicates, concatenate cells from another column and delete row

[JeremyG12]

I have the below spreadsheet data that I need to determine if there are duplicate values in column A, if there are, then the values in column B (where a match exists) should be concatenated together and the duplicate row deleted. Note: the data that needs to be checked for duplicates does not start at the top of the column. It would be a range that needs to be checked for the duplicates (i.e., starting on Row 9 and going to Lastrow would work).

I've tried various approaches but haven't been able to get something working correctly. Appreciate the help!

Column A	Column B
other data
other details
Test 3	abc, zzu, abf
Test 1	jjff, jqqq
Test 3	skjk
Test 4	ksjs, kkskj
Test 3	lok

Final output:

Column A	Column B
other data
other details
Test 3	abc, zzu, abf, skjk, lok
Test 1	jjff, jqqq
Test 4	ksjs, kkskj

 

[Sergius]

Using Power Query:

let
    from = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    result = Table.Group(from, {"Column1"}, {{"Column2", each Text.Combine([Column2],", "), type text}})
in
    result

Book1.xlsm
	A	B
1	Column1	Column2
2	other data
3	other details
4	Test 3	abc, zzu, abf, skjk, lok
5	Test 1	jjff, jqqq
6	Test 4	ksjs, kkskj
Table2

 

[JeremyG12]

That would solve it, but it needs to be done via VBA.

 

[Alex Blakenburg]

See if this works for you.
Use a copy of your workbook it will overwrite the existing data.

Change the sheet name to your sheet name

Sub ConcatenateLines()

    Dim shtData As Worksheet
    Dim rowLast As Long
    Dim rngData As Range, arrData As Variant
    Dim dictData As Object, dictKey As String
    Dim i As Long
    
    Set shtData = Worksheets("Sheet1")          ' <--- Change to your sheet name or use ActiveSheet
    With shtData
        rowLast = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData = .Range("A9:B" & rowLast)
        arrData = rngData.Value
    End With

    Set dictData = CreateObject("Scripting.dictionary")
    dictData.CompareMode = vbTextCompare
    
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 1)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = arrData(i, 2)
        ElseIf dictData(dictKey) = "" Then
            dictData(dictKey) = arrData(i, 2)
        Else
            dictData(dictKey) = dictData(dictKey) & ", " & arrData(i, 2)
        End If
    Next i
    
    ' Write output
    rngData.ClearContents
    rngData.Columns(1).Resize(dictData.Count).Value = Application.Transpose(dictData.keys)
    rngData.Columns(2).Resize(dictData.Count).Value = Application.Transpose(dictData.items)
End Sub

 

[JeremyG12]

@Alex Blakenburg, this worked perfectly! Thank you so much!

 

[Alex Blakenburg]

You’re welcome.
Just an FYI, transpose ha a limit of 65,536 lines, so if the number of rows in your resulting output is going to exceed that, come back to me.