Delete duplicate cells on rows

[Dwl1954]

I have a spreadsheet containing many thousands of rows extracted from a document management database. Each row has multiple columns. Across those colimns for each row, some cells may contain duplicate data. E.g.

A1 = “legal”

B1 = “legal”

C1 = “Warranty”

D1 = “warranty”

E1= “warranty”

F1 = “guarantee”

G1=”legal”

The vba code would need to identify in the row the duplicate values and delete cell (shift left), so the result would be

A1 = ‘legal’

B1 = “warranty”

C1 =”guarantee

Not all rows would contain duplicate cells and the duplicates will not occur in the same position in each row. The VBA would be reiterative for however many rows may exist.

[mana]

Option Explicit


Sub test()
    Dim dic As Object
    Dim w()
    Dim i As Long, j As Long
    Dim n As Long
    Dim s
    
    Set dic = CreateObject("scripting.dictionary")
    
    With Cells(1).CurrentRegion
        ReDim w(1 To .Rows.Count, 1 To .Columns.Count)
        
        For i = 1 To .Rows.Count
            n = 0
            dic.RemoveAll
            For j = 1 To .Columns.Count
                s = .Cells(i, j).Value
                If s = "" Then Exit For
                If Not dic.exists(s) Then
                    dic(s) = True
                    n = n + 1
                    w(i, n) = s
                End If
            Next
        Next
        .Value = w
    End With
    
End Sub

[Dwl1954]

Hi man's. Thanks very much for this. I'm not in a position to try it out right now, I have a question which will no doubt be obvious to every one else, but my VBA knowledge is extremely limited to follow code examples with a manual to decipher exactly what each lines does. I forgot to mention in my original post, these duplications may occur several times per row. Other cells may be empty, the repetitive cells may start and end in any column in the row. Kind regards

[mana]

This may be easier to understand.

Option Explicit

Sub test2()
    Dim r As Range
    Dim c As Range
    
    Application.ScreenUpdating = False
    
    Set r = Cells(1).CurrentRegion
    r.Copy
    r.Cells(1).Offset(, r.Columns.Count).PasteSpecial Transpose:=True
    r.EntireColumn.Delete
        
    Set r = Cells(1).CurrentRegion
    For Each c In r.Columns
        c.RemoveDuplicates 1
    Next
        
    Set r = Cells(1).CurrentRegion
    r.Copy
    r.Cells(1).Offset(, r.Columns.Count).PasteSpecial Transpose:=True
    r.EntireColumn.Delete
    
    Cells(1).Select
    
End Sub

[Dwl1954]

Thank you very much. Will give a go as soon as I can.

[Dwl1954]

Hi Mana

This works perfectly, but I have just realised a wrinkle I had not anticipated. I need to preserve the positional placement of other cell values within any given row, because they align with my header row titles. Is there anyway to do this?

[mana]

Option Explicit


Sub test3()
    Dim dic As Object
    Dim w()
    Dim i As Long, j As Long
    Dim n As Long
    Dim s
     
    Set dic = CreateObject("scripting.dictionary")
     
    With Cells(1).CurrentRegion.Offset(1)
        ReDim w(1 To .Rows.Count, 1 To .Columns.Count)
         
        For i = 1 To .Rows.Count
            n = 0
            dic.RemoveAll
            For j = 1 To .Columns.Count
                s = .Cells(i, j).Value
                If s = "" Then Exit For
                If Not dic.exists(s) Then
                    dic(s) = True
                    n = n + 1
                    w(i, n) = s
                End If
            Next
        Next
        .Value = w
    End With
     
End Sub

[mana]

Option Explicit


Sub test4()
    Dim r As Range
    Dim i As Long
     
    Application.ScreenUpdating = False
     
    Set r = Cells(1).CurrentRegion
    r.Copy
    r.Cells(1).Offset(, r.Columns.Count).PasteSpecial Transpose:=True
    r.EntireColumn.Delete
     
    Set r = Cells(1).CurrentRegion
    For i = 2 To r.Columns.Count
        r.Columns(i).RemoveDuplicates 1
    Next
     
    Set r = Cells(1).CurrentRegion
    r.Copy
    r.Cells(1).Offset(, r.Columns.Count).PasteSpecial Transpose:=True
    r.EntireColumn.Delete
     
    Cells(1).Select
     
End Sub