Delete duplicate cell values in rows

Alistair_Mair used Ask the Experts™
I have an excel spreadsheet with multiple colums and with all the records in rows. Some of the colums have duplicate value which i need to delete and have only one instance of the duplicate value appear in a single cell with all other unique values seperated by a comma as per the attached example.
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2010

On Row 4 of your sample sheet, you list DOS - JOHN MASON twice, and your sample output for that row lists that entry twice.

Then, on Row 10, you list DOS - JOHN MASON twice again, but your sample output for that row lists that value once but then for some odd reason lists SP-100 - LAUREL WEINER twice.

I think you need to take another crack on defining your requirements :)


Revised file as per your comment, apologise for the confusion.
Top Expert 2010
OK, this workbook is working for me:


It uses a Dictionary object to take care of duplicates, as noted in my article:

The code I used:

Sub RemoveDups()
    Dim LastR As Long, r As Long, LastC As Long, c As Long, DestR As Long
    Dim dic As Object
    Dim SourceWs As Worksheet, DestWs As Worksheet
    Dim TestValue As String
    Set SourceWs = ThisWorkbook.Worksheets("Input")
    Set DestWs = Workbooks.Add.Worksheets(1)
    With SourceWs
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        For r = 1 To LastR
            Set dic = CreateObject("Scripting.Dictionary")
            dic.CompareMode = vbTextCompare
            LastC = .Cells(r, .Columns.Count).End(xlToLeft).Column
            For c = 1 To LastC
                TestValue = .Cells(r, c)
                If Not dic.Exists(TestValue) Then dic.Add TestValue, TestValue
            DestR = DestR + 1
            DestWs.Cells(DestR, 1) = Join(dic.Keys, ", ")
            Set dic = Nothing
    End With
    MsgBox "Done"
End Sub

Open in new window


Many thanks for your help, much appreciated.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial