Help With Deleting Duplicate Rows Code

[Dazzawm]

I have the following code that when I select a column it deletes the entire row if the data is the same in rows in that column, What I need added to the code is that when it has to delete rows it colours in the remaining row. Thanks

Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim r As Long
Dim N As Long
Dim V As Variant
Dim rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(rng.Row, "#,##0")
N = 0
For r = rng.Rows.Count To 2 Step -1
If r Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(r, "#,##0")
End If
V = rng.Cells(r, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then
rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(r).EntireRow.Delete
N = N + 1
End If
End If
Next r
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub

 

[Dazzawm]

What about the other columns?

 

[mirabeau]

What about the other columns?

I was kinda hoping that you'd figure that one out. (modifications from orig code in red)

Sub delrowsanew()
Dim d As Object, u(), nr&, xcol As Range
Dim c As Range, col, i&, k&, x, scol as range, vcol as range
Set d = CreateObject("scripting.dictionary")
nr = Cells.Find("*", after:=Cells(1), searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
ReDim u(1 To nr, 1 To 1)
Set c = Cells(1, Columns.Count)
col = Selection.EntireColumn
Set xcol = Cells.Range("X:X")
Set scol = Cells.Range("S:S")
Set vcol = Cells.Range("V:V")

For i = 1 To nr
    x = col(i, 1)
    If Not d.exists(x) Then
        d.Add x, i
    Else
        u(i, 1) = 1
        k = k + 1
        Cells.Rows(d(x)).Interior.Color = vbCyan
        xcol(d(x)) = xcol(d(x)) + xcol(i)
        scol(d(x)) = scol(d(x)) + scol(i)
        vcol(d(x)) = vcol(d(x)) + vcol(i)
End If
Next i

c.Resize(nr) = u
Cells.Resize(nr, Columns.Count).Sort c, 1
If k > 0 Then Cells.Resize(k, Columns.Count).Delete xlUp
End Sub

The modification to include a space not given is this, but it should be obvious from a previous post.

 

[Dazzawm]

Thanks all sorted

 

[mirabeau]

Thanks all sorted

Good to hear that all worked out OK.

As a codewriter yourself you know that encouraging feedback is always encouraging.

 

[Dazzawm]

I wouldnt say I was a 'codewriter' lol. Thanks for the ego boost though. I am very new to it and have only just learnt to write the most basic of all basic codes!

 

[mirabeau]

I wouldnt say I was a 'codewriter' lol. Thanks for the ego boost though. I am very new to it and have only just learnt to write the most basic of all basic codes!

dazwm,

If your problem has a lot of rows that code I posted can be probably pretty slow, coz I only did it to address the (small sized) problem as you posted it.

To modify that approach for large data sets you can replace it by this, which should do 60k or so rows much faster. (also note there's a specific selection for Column B a few lines from the top, which you can change to whatever you like, or delete if you want to select manually)

Sub delrowsredo2()
Dim d As Object, u(), nr&, nc&, rng As Range
Dim c As Range, col, i&, k&, x, uni As Range
nr = Cells.Find("*", after:=Cells(1), searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
nc = Cells.Find("*", after:=Cells(1), searchorder:=xlByColumns, _
    searchdirection:=xlPrevious).Column
Set rng = Cells.Range("A1").Resize(nr, nc)
ReDim u(1 To nr, 1 To 1)
Set c = rng(1).Offset(, nc)
Range("B1").Select 'change this if you want a different column
col = Selection.EntireColumn
Set d = CreateObject("scripting.dictionary")
Set uni = Union(rng.Range("X:X"), rng.Range("S:S"), rng.Range("V:V"))

For i = 1 To nr
    x = col(i, 1)
    If d(x) = vbNullString Then d(x) = i Else _
        u(i, 1) = 1: _
        k = k + 1: _
        rng.Rows(d(x)).Interior.Color = vbCyan: _
        uni(d(x)) = uni(d(x)) & " " & uni(i)
Next i
c.Resize(nr) = u
rng.Resize(nr, nc + 1).Sort c, 1
If k > 0 Then Cells.Resize(k, nc + 1).Delete xlUp
End Sub

As a codewriter making good headway you might be inclined to note the differences between this and the earlier code.

If you're really a speed fiend on large problems, it can I think be done more quickly again using a somewhat different approach.

However, I guess your problem should be OK solved by now.

 

[Dazzawm]

Thanks for everything Mirabeau.