Delete duplicate cell values in rows

Alistair_Mair
Alistair_Mair used Ask the Experts™
on
Hi,
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.
DeleteRows.xlsx
Comment
Watch Question

Do more with

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

Commented:
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 :)

Author

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

Q-27727189.xlsm

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

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html

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
            Next
            DestR = DestR + 1
            DestWs.Cells(DestR, 1) = Join(dic.Keys, ", ")
            Set dic = Nothing
        Next
    End With
    
    MsgBox "Done"
    
End Sub

Open in new window

Author

Commented:
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