VBA to delete duplicate and blank rows

[slora00]

Hello community, I hope y'all doing fine. I need some help with the following task:

I have a 13k rows file, but with at least 2000 duplicates, and I need to delete them but considering column N.

I need a VBA code that deletes all duplicates on column A that are empty on column N. I tried the following:

Dim ColorRng As Range
Dim ColorCell As Range
Dim hoja As Worksheet
Set hoja = ActiveSheet
Set ColorRng = hoja.Range("A2:AB" & Cells(Rows.Count, "A").End(xlUp).Row)

For Each ColorCell In ColorRng
    If WorksheetFunction.CountIf(ColorRng, ColorCell.Value) > 1 And IsEmpty(Range("N2:N" & Cells(Rows.Count, "A").End(xlUp).Row)) = True Then
        ColorCell.EntireRow.Delete
            
    Else
    ColorCell.Interior.ColorIndex = xlNone
        
    End If
Next

But the "IsEmpty" part seems to be not working.

Feel free to either correct my code, or write a new one instead.

Thank you in advance!

 

[Flaiban]

Try to use following code:

Sub DeleteDuplicateAndBlanksRows()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim cln As New Collection
    Dim strMyKey As String
    Dim rngBlanks As Excel.Range
   
    Application.ScreenUpdating = False
   
    lngLastRow = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngMyRow = lngLastRow To 1 Step -1
        strMyKey = Trim(Range("A" & lngMyRow)) & Trim(Range("A" & lngMyRow))
        If Len(strMyKey) = 0 Then
            Rows(lngMyRow).Delete
        Else
            On Error Resume Next
                cln.Add strMyKey, CStr(strMyKey)
                If Err.Number <> 0 Then
                    Rows(lngMyRow).Delete
                End If
            On Error GoTo 0
        End If
    Next lngMyRow
   
    With Worksheets("Sheet1")
        On Error Resume Next
        Set rngBlanks = Intersect(.DataBodyRange, .Range("N2:N" & Cells(Rows.Count, 1).End(xlUp).Row)).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not rngBlanks Is Nothing Then
        rngBlanks.EntireRow.Delete
        End If
    End With
   
    Application.ScreenUpdating = True

End Sub

 

[kevin9999]

Another option.

Option Explicit
Sub slora00()
    Dim ArrIn, ArrTemp, ArrOut, dict, v, tmp
    Dim n As Long, i As Long, LCol As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    ArrIn = ws.Range("A2:N" & ws.Cells(Rows.Count, 1).End(3).Row).Value
    n = UBound(ArrIn, 1)
    ReDim ArrTemp(1 To n, 1 To 1)
    ReDim ArrOut(1 To n, 1 To 1)
    
    Set dict = CreateObject("scripting.dictionary")
    For i = 1 To n
        v = ArrIn(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0)
        tmp = dict(v)
        tmp(0) = tmp(0) + 1
        dict(v) = tmp
    Next i
    
    For i = 1 To n
        ArrTemp(i, 1) = dict(ArrIn(i, 1))(0)
    Next i
    
    For i = 1 To n
        If ArrTemp(i, 1) > 1 And ArrIn(i, 14) = "" Then ArrOut(i, 1) = 1
    Next i
    
    ws.Cells(2, LCol).Resize(n).Value = ArrOut
    i = WorksheetFunction.Sum(Columns(LCol))
    Range(Cells(2, 1), Cells(n + 1, LCol)).Sort Key1:=Cells(2, LCol), order1:=1, Header:=2
    If i > 0 Then Cells(2, LCol).Resize(i).EntireRow.Delete
End Sub

 

[slora00]

Thank you so much guys! Both your codes functioned perfectly! Thanks for the rapid response.

 

[kevin9999]

Thank you so much guys! Both your codes functioned perfectly! Thanks for the rapid response.

Glad we could help & thanks for the feedback

 

[slora00]

Glad we could help & thanks for the feedback

Kevin, I need something really similar to what you just coded recently. Now, instead of deleting duplicate and blank rows, I have a column (AC) that has a text (Keep) and I want to delete those rows which cells are duplicate on column A and DO NOT have "Keep" on column AC.

Could you give me a hand on that?

 

[kevin9999]

Kevin, I need something really similar to what you just coded recently. Now, instead of deleting duplicate and blank rows, I have a column (AC) that has a text (Keep) and I want to delete those rows which cells are duplicate on column A and DO NOT have "Keep" on column AC.

Could you give me a hand on that?

Yes, but I'm going to be off-line for a few hours. Later today.

 

[slora00]

Yes, but I'm going to be off-line for a few hours. Later today.

Couldn't ask more than that. Thank you very much!

 

[kevin9999]

Try this

Option Explicit
Option Compare Text
Sub Keep()
    Dim ArrIn, ArrTemp, ArrOut, dict, v, tmp
    Dim n As Long, i As Long, LCol As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    ArrIn = ws.Range("A2:AC" & ws.Cells(Rows.Count, 1).End(3).Row).Value
    n = UBound(ArrIn, 1)
    ReDim ArrTemp(1 To n, 1 To 1)
    ReDim ArrOut(1 To n, 1 To 1)
    
    Set dict = CreateObject("scripting.dictionary")
    For i = 1 To n
        v = ArrIn(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0)
        tmp = dict(v)
        tmp(0) = tmp(0) + 1
        dict(v) = tmp
    Next i
    
    For i = 1 To n
        ArrTemp(i, 1) = dict(ArrIn(i, 1))(0)
    Next i
    
    For i = 1 To n
        If ArrTemp(i, 1) > 1 And Not ArrIn(i, 29) Like "*Keep*" Then ArrOut(i, 1) = 1
    Next i
    
    ws.Cells(2, LCol).Resize(n).Value = ArrOut
    i = WorksheetFunction.Sum(Columns(LCol))
    Range(Cells(2, 1), Cells(n + 1, LCol)).Sort Key1:=Cells(2, LCol), order1:=1, Header:=2
    If i > 0 Then Cells(2, LCol).Resize(i).EntireRow.Delete
End Sub

 

[slora00]

Try this

Option Explicit
Option Compare Text
Sub Keep()
    Dim ArrIn, ArrTemp, ArrOut, dict, v, tmp
    Dim n As Long, i As Long, LCol As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
   
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    ArrIn = ws.Range("A2:AC" & ws.Cells(Rows.Count, 1).End(3).Row).Value
    n = UBound(ArrIn, 1)
    ReDim ArrTemp(1 To n, 1 To 1)
    ReDim ArrOut(1 To n, 1 To 1)
   
    Set dict = CreateObject("scripting.dictionary")
    For i = 1 To n
        v = ArrIn(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0)
        tmp = dict(v)
        tmp(0) = tmp(0) + 1
        dict(v) = tmp
    Next i
   
    For i = 1 To n
        ArrTemp(i, 1) = dict(ArrIn(i, 1))(0)
    Next i
   
    For i = 1 To n
        If ArrTemp(i, 1) > 1 And Not ArrIn(i, 29) Like "*Keep*" Then ArrOut(i, 1) = 1
    Next i
   
    ws.Cells(2, LCol).Resize(n).Value = ArrOut
    i = WorksheetFunction.Sum(Columns(LCol))
    Range(Cells(2, 1), Cells(n + 1, LCol)).Sort Key1:=Cells(2, LCol), order1:=1, Header:=2
    If i > 0 Then Cells(2, LCol).Resize(i).EntireRow.Delete
End Sub

Hello Kevin, just tested the code and it works, but there's an issue. When it deletes the rows, the macro shifts up some rows and takes away the table headers. If it's not much to ask, is there any way to fix this?