CODEWITHSUNDEEP
vbaexcel
CamSpy
CamSpy

Reputation: 401

Find and delete duplicate cells in rows, not columns

I currently have a VBA macro that does it already but not exactly what I need.

Here's the VBA:

Sub StripRowDupes()
    Do Until ActiveCell = ""
        Range(ActiveCell, ActiveCell.End(xlToRight)).Select
        For Each Cell In Selection
            If WorksheetFunction.CountIf(Selection, Cell) > 1 Then
                Cell.ClearContents
            Else
            End If
        Next Cell
        On Error Resume Next
        Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
        ActiveCell.Range("A2").Select
    Loop
End Sub

And an example sheet data (dog and ship are duplicates in each row):

A   | B    |   C    |   D
dog | cat  |  goat  |  dog
car | ship |  plane |  ship

After running this macro it deletes the first instance of a duplicate from row and result looks like this:

A   | B     |   C
cat | goat  |  dog
car | plane |  ship

What I require is to delete the last instance of duplicates, not the first, to have the following result:

A   | B    |   C
dog | cat  |  goat
car | ship |  plane

What to change in the current VBA script to get the desired result?

Upvotes: 2

Views: 195

Answers (1)

Dmitry Pavliv
Dmitry Pavliv

Reputation: 35863

UPD:

Sub StripRowDupes()
    Dim c As Range, rng As Range
    Dim lastcol As Long
    Dim i As Long
    Dim rngToDel As Range, temp As Range

    Application.ScreenUpdating = False

    Set c = ActiveCell

    Do Until c = ""
        lastcol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
        Set rng = c.Resize(, lastcol - c.Column + 1)

        For i = lastcol To c.Column Step -1
            If WorksheetFunction.CountIf(rng, c.Offset(, i - 1)) > 1 Then c.Offset(, i - 1).ClearContents
        Next i

        On Error Resume Next
        Set temp = rng.SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0

        If Not temp Is Nothing Then
            If rngToDel Is Nothing Then
                Set rngToDel = temp
            Else
                Set rngToDel = Union(rngToDel, temp)
            End If
        End If

        Set c = c.Offset(1)
        Set temp = Nothing
    Loop

    If Not rngToDel Is Nothing Then rngToDel.Delete Shift:=xlToLeft

    Application.ScreenUpdating = True
End Sub

Upvotes: 3

Related Questions