Concatenate cells and delete duplicates

I have an excel 2007 spreadsheet that lists
items on multiple rows for the same customer.

Each sheet will list anywhere from 25 to 100 individual customers.

I need to identify the duplicates, concatenate
the "Items" to a single cell on the first row, and
delete the duplicate rows. eg:

Cust #| Item
1 | A
1 | B
1 | C
2 | B
2 | E
3 | A
3 | C
3 | E

The result should look like:

Cust# | New Item
1 | A, B, C
2 | B, E
3 | A, C, E

Can this be done? Thanks!

First, you need to add a little "string concatentation" utility to your sheet to make this easier. And the macro that follows will do the work you wanted. It assumes there's nothing in columns C and D. If that won't work, let me know and we'll insert some blank columns first.

Press Alt-F11 to open the VBEditor
Click Insert > Module
Paste in all this code (function and macro)

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
            Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
    ' code base by Mike Rickson, MrExcel MVP
    ' used as exactly like COUNTIF() with two additional parameters
    ' of delimiter and "no duplicates" as TRUE/FALSE if concatenated values
    ' might include duplicates  ex. =ConcatIf($A$1:$A$10,C1,$B$1:$B$10,", ",True)

Dim i As Long, j As Long

With compareRange.Parent
    Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
End With

If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                    stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function


Sub Consolidate()
Dim i As Integer, lastArow As Long, lastCrow As Long
lastArow = Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
    
    Range("A1:A" & lastArow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
    Range("B1").Value = "Items"
    lastCrow = Range("C" & Rows.Count).End(xlUp).Row


    Range("D2:D" & lastCrow).FormulaR1C1 = "=concatif(R2C1:R9C1,RC[-1],R2C2:R9C2,"", "")"
    Columns("D:D").Copy
    Columns("D:D").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.EnableEvents = True
Application.Calculation = xlAutomatic
    Calculate
    Columns("A:B").Delete Shift:=xlToLeft
    Range("C1").Select
End Sub

Press Alt-F11 to close the editor
Save your sheet.

Press Alt-F8 and run the "consolidate" macro.

Hello plente,

Welcome to the Forum!

This macro doesn't care if the data is sorted or not. It only clears the cells involved and not the entire row. You can change the starting cell if you need to. It is marked in the code in reed.

Sub Macro1()

  Dim C As Long
  Dim Cell As Range
  Dim Data As String
  Dim DSO As Object
  Dim Key As Variant
  Dim Keys As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set Rng = Range("A2")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Range(Rng, RngEnd))
    
    Set DSO = CreateObject("Scripting.Dictionary")
    
      For Each Cell In Rng
        If Not DSO.Exists(Cell.Value) Then
           DSO.Add Cell.Value, Cell.Offset(0, 1).Value
        Else
           Data = DSO(Cell.Value)
           DSO(Cell.Value) = Data & ", " & Cell.Offset(0, 1).Value
        End If
      Next Cell
      
      Keys = DSO.Keys
      R = Rng.Row
      C = Rng.Column
      Rng.Resize(Columnsize:=2).ClearContents
      
        For Each Key In Keys
          Cells(R, C) = Key
          Cells(R, C + 1) = DSO(Key)
          R = R + 1
        Next Key
        
    Set DSO = Nothing
    
End Sub

Adding the Macro
1. Copy the macro above pressing the keys CTRL+C
2. Open your workbook
3. Press the keys ALT+F11 to open the Visual Basic Editor
4. Press the keys ALT+I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL+V
7. Make any custom changes to the macro if needed at this time.
8. Save the Macro by pressing the keys CTRL+S
9. Press the keys ALT+Q to exit the Editor, and return to Excel.

To Run the Macro...
To run the macro from Excel, open the workbook, and press ALT+F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Thanks for the replies! I guess a tad more info was needed. The "Cust#" range is indeed column A, but the "Item" range on the worksheet is actually AC, and there are indeed several more columns to the right of AC. In fact, the entire spreadsheet is from A - AH. The actual rows of customers are anywhere from a single row to as many as seven or eight, each identical except for the "Item" column.

*Update* JBeaucaire; I have been trying to make your macro work. I tried running it against a simple, two column worsksheet. It eliminates the dups and copies the cust#s to row C as expected, but all I get in row D following each number is "#NAME?"

Leith Ross; Your macro works perfectly against the two column worksheet, but how can I make it find and concatenate the correct column?

Thanks again
JR Jones

that's because you didn't install the UDF as well.

If you post up a sample of your actual workbook, I can tweak it quickly and get it working.

Sorry if I'm dense, so let's start over. You want to concatenate all the comments in column AC that match the code in column C? Is that correct?

Where is this concatenation supposed to appear when it's done?

And what are all those concatenated duplicate dates in column B?

So, all the values in AC matching invoice in C, concatenated to another spot, then copied BACK over column AC, then duplicates removed?

Perhaps this is completed onto a second sheet to leave the original data alone? If so, what cells would you really want in that final report?

Here's your sheet back with the data being created for you over in columns AP & AQ. Run the "Consolidate" macro.

Here's what that macro looks like. It does still use the ConcatIf UDF as well, so both pieces of code need to be on your sheet.

Option Explicit

Sub Consolidate()
Dim i As Integer, lastAProw As Long, lastArow As Long
lastArow = Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Range("AP:AQ").ClearContents
    
    Range("C1:C10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AP1"), Unique:=True
    Range("AQ1").Value = "Recommended"
    lastAProw = Range("C" & Rows.Count).End(xlUp).Row

    Range("AQ2:AQ" & lastAProw).FormulaR1C1 = "=concatif(C[-40],RC[-1],C[-14],"", "")"
    Columns("AQ:AQ").Copy
    Columns("AQ:AQ").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Application.EnableEvents = True
Application.Calculation = xlAutomatic
Range("AQ1").Select
End Sub

Thanks again, JBeaucaire. I can't believe the time & effort that you've put into this!

I'm really feeling like a dummy here. I was out of town for most of the weekend, but I was playing with this and trying to make it work Friday evening & most of yesterday. Man, I can usually look at a macro and muddle out what the relevant operations are, but not this one How does it know to get values from column AC?

It runs OK on the 'trialsheet' that I attached, but when I try to run it against the actual speadsheet, it fails. Just gives the "NAME" error in column AQ. Googling around for info on UDFs is telling me that maybe they aren't enabled on my spreadsheet? I even saved the 'TrialSheet' file as macro-enabled to the XLStart folder, and the spreadsheet is saved in a trusted location. I finally copied & pasted the data from the real sheet into the 'TrialSheet" workbook, and it works just fine! What am I missing to enable UDFs?

As far as a second sheet, That's not necessary if the duplicates can be just deleted. The mailer is going to need data from D,E,F.G,H,I,O,P,Q,T,U, & of course, AC.

Here's a fresh copy of the sheet, in case I messed something up on the other one as well.

I'm gonna owe ya big time if this can be made to work.

I don't use Excel 2007, so I can't advise you on that. You should ONLY be working with .xlsm files, I know THAT much. .xlsx don't use macros at all, it's a secure format.

There was a wee typo in the macro, though it would still work. Here's your sheet again WITH the macro and UDF installed. You can actually save those module out to the hard drive as .bas files from inside the VBEditor (File > Export File while the module is highlighted). That could speed up installing it into future sheets.

This works. Not sure what's left for you here.

Delete rows, sure? But delete them where? Is this a whole new thing or something more you want to happen within the existing macro? The list I'm making doesn't have any duplicates....

The extra rows that contained the values in AC that was copied to AQ. Actually, I just figured that one out for myself. I just added :

Sub Delete_Duplicates()
'
' Delete_Duplicates Macro
' Gets rid of extra rows in Recommended Services
'

'
Columns("A:AJ").Select
Range("AJ1").Activate
ActiveSheet.Range("$A$1:$AJ$420").RemoveDuplicates Columns:=3, Header:= _
xlYes
Range("AK2").Select
End Sub

And it got rid of the extra data and everything lines up perfectly with the appropriate cell in AQ!

JBeaucaire, thank you so much for your patience and expertise. I hope I can one day repay you.

I'd still like to know which line in your code identifies column AJ as a source

Thanks;
JR Jones

Start your own thread. Include your sample workbook and this macro if desired. PM me a link to the new thread if you wish.