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