DeleteDuplicateRows Macro Help Needed | Modify to only delete duplicate rows if the entire row is empty

[SimplyCole]

Good day,

I am working on a Macro for one of my coworkers that should delete duplicate rows based on Social Security Numbers in Column A. Right now, I have it deleting the duplicate row, but I need to add a condition that if one (or both) duplicate rows contain data outside of Column A's SSN, then leave the rows. I need it to ONLY delete duplicate Rows if there is no data outside of the duplicate SSN's.

My thinking was to possibly check Column B, cell to the right of the duplicate SSN to see if that contained any data; if it did, then leave that duplicate SSN in the worksheet. If it did not, go ahead and delete that duplicate SSN.

Any help would be GREATLY appreciated, as I am a novice when it comes to VBA.

For reference, here is the code I am working with:

Public Sub DeleteDuplicateRows()

' This macro will delete all duplicate rows which reside under
' the first occurrence of the row.

' Use the macro by selecting a column to check for duplicates
' and then run the macro and all duplicates will be deleted, leaving
' the first occurrence only.

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

I placed the .csv document I am working on here: http://itscol.es/excel/401k to principal.csv as well as the Personal.xlsb I have here: http://itscol.es/excel/Personal.xlsb

I appreciate any help you lovely folks can offer.

Thank you,

Cole

 

[SimplyCole]

Anyone have any ideas on this at all? Any help would be greatly appreciated!

Thank you,

Cole

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG14Apr02
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
 [COLOR="Navy"]If[/COLOR] Application.CountA(Dn.Offset(, 1).Resize(, Columns.Count - 1)) = 0 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] nRng = Union(.Item(Dn.Value), Dn)
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, .Item(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[SimplyCole]

Thank you MickG! I've been trying to determine what the code is doing for the last 30 minutes. In this particular spreadsheet, I have 394 rows of data. When I run your Macro, it drops me down to 385 lines, but I've still got some duplicate SSN's.

I haven't been able to pinpoint what it is removing, but the total amount stay's the same (that's good!). Some of the duplicate SSN's in column A are the empty SSN's that need to be deleted (leaving the other SSN/Row with the data in to keep the total correct).

Thanks again for your help!

Cole

 

[MickG]

Run the code again but replace the last line with :-

nRng.Interior.ColorIndex = 6

This will colour the cells for removal Yellow", to let you Know which they are.

If I run the formula "Countif(A:A,A1)", in a spare column, and drag down , then check the "2"s , the code only leaves duplicates that have data in their rows !!!
Which appears correct !!!

 

[SimplyCole]

Thank you again, MickG! I see what your code is doing now; it's ONLY looking for duplicate SSN's that have no data in other fields on that row and deleting BOTH of the rows that pertain to that same SSN. I have duplicate SSN's that one row is blank, and the other contains amounts in it. I'd like to delete ONLY the rows of duplicate SSN's that are blank (leaving me the one SSN row with the numerical data so it doesn't mess up my totals at the end of the report).

What I'm trying to do is to loop through the SSN column (A), find all the duplicate SSN's, then check to see if one of them is completely void of data; if it is, delete only that one row. When I run my original script, it finds all of the duplicate SSN's and deletes the duplicate, leaving one of the SSNs. However, it doesn't differentiate between SSN's that have data to the right of their 'A_' cell, it simply deletes the SSN that is the duplicate (the second entry). I'm not sure how I can append it to check the cell to the right of it for data. If it does contain data, I do not want to delete it; if it does not contain data, then it's okay to delete it and continue on.

Thanks so much for your help! I GREATLY appreciate it!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG15Apr33
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
       [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
     [COLOR="Navy"]If[/COLOR] .Item(K).Count > 1 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Application.CountA(R.Offset(, 1).Resize(, Columns.Count - 1)) = 0 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = R
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, R)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[SimplyCole]

Works like a champ! That's what I'm talking about! Right on, Mick! You're the man!

Thank you SO much for your help in this matter!

 

[MickG]

You're welcome