VBA to remove duplicate entries in a column

[bsrivatsa]

Hi all,

I have names of our employees in column A that is being populated from another spreadsheet using "If" formulae. I need to delete the duplicate entries and also delete the row. For this I am trying the following VBA code, but running into problems. The code is stopping at the "Lastrow" line with a run-time error message 438- "object doesn't support this property or method". Any help would be greatly appreciated.

Also I would like to delete the rows with blanks in this column.

Sub DelDuplicates()

Dim lastrow As Long, fnd As Variant, loop_ctr As Integer

With Sheets("Bonus Calculation")
    For loop_ctr = 3 To 100
        lastrow = Cells(Rows.Count, .Column(1)).End(xlUp).Row
        fnd = Application.Match(.Range("A" & loop_ctr).Value, Range(Cells(.Row + 1, .Column), Cells(lastrow, .Column)), 0)
        
        If Not IsError(fnd) Then
        .Range("A" & loop_ctr).Rows("1:1").EntireRow.Delete Shift:=xlUp
        End If
    Next loop_ctr
End With
End Sub

[Trebor76]

Hi bsrivatsa,

Try this (though initially on a copy of your data as the results cannot be undone if they're not as expected):

Option Explicit
Sub Macro3()

    Dim objMyUniqueData As Object
    Dim rngMyCell As Range
    Dim rngDelRange As Range
    Dim lngLastRow As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    lngLastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

    For Each rngMyCell In Sheets("Sheet1").Range("A3:A" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objMyUniqueData.Exists(CStr(rngMyCell)) = False Then
                objMyUniqueData.Add CStr(rngMyCell), rngMyCell
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = rngMyCell
                Else
                    Set rngDelRange = Union(rngDelRange, rngMyCell)
                End If
            End If
        Else
            If rngDelRange Is Nothing Then
                Set rngDelRange = rngMyCell
            Else
                Set rngDelRange = Union(rngDelRange, rngMyCell)
            End If
        End If
    Next rngMyCell
    
    If Not rngDelRange Is Nothing Then
        rngDelRange.EntireRow.Delete
    End If
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert

[bsrivatsa]

Thank you trebor76.

I found this solution elsewhere online and seems to work well for me.

Sub RemoveDuplicateRows()


Dim MyRange As Range
Dim LastRow As Long

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set MyRange = ActiveSheet.Range("A1:D" & LastRow)
MyRange.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

[Trebor76]

NP. Thanks for the rep