Using Excel VBA to delete duplicate rows of data

I am trying to create a module that will allow me to delete duplicate rows of data.  The code that I have is below, but it seems that the for-next statement never finishes.  Any assistance anyone can give would be greatly appreciated.

\\BEGIN CODE\\
Option Explicit
Sub DeleteDuplicates()
'   Variable declaration
    Dim lngRow As Long, lngColumn As Long
    Dim lngEnd As Long
   
'   Turn off screen updating
    Application.ScreenUpdating = False
   
'   Set error handling
    On Error GoTo canceled:

'   Set begin and end row to same value
    lngRow = 2
    lngEnd = lngRow

'   Determine the range of used cells
    Do While Cells((lngEnd + 1), 1) <> ""
        lngEnd = lngEnd + 1
    Loop
   
'   Ask the user what column should be tested for duplicate values
    lngColumn = InputBox("Which column should be" & vbNewLine & _
        "checked for duplicates?", "Not so fast...")
       
'   Begin the process of removing duplicates
    For lngRow = 2 To lngEnd
        If Cells(lngRow, lngColumn) = Cells(lngRow - 1, lngColumn) Then
            Rows(lngRow).Select
            Selection.Delete
            lngRow = lngRow - 1
        End If
    Next lngRow

'   Turn on screen updating
    Application.ScreenUpdating = True

'*************'
'ERROR HANDLER'
'*************'
Exit Sub
canceled:
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Operation canceled by user.", vbInformation Or vbOKOnly, "Canceled"

End Sub

\\END CODE\\

Thanks!

heath

heath9916Asked:
Who is Participating?
 
mvidasCommented:
Hi Heath,

I changed the method of checking for the duplicates, but you'll find this runs much faster and more efficient.  Please let me know if you have any questions!

Option Explicit
Sub DeleteDuplicates()
'Variable declaration
 Dim StartRow As Long, CheckRG As Range, ColToCheck As Range
 Dim UniqCells() As String, UniqCount As Long, i As Long, DelRG As Range
 
'Set row to start searching for duplicates
 StartRow = 2

'Determine the range of used cells
 Set CheckRG = Intersect(Rows(StartRow & ":65536"), ActiveSheet.UsedRange)
 If CheckRG Is Nothing Then Exit Sub 'Nothing to check
 
'Ask the user what column should be tested for duplicate values
 Do
  Set ColToCheck = Application.InputBox(prompt:="Which column should be" & vbNewLine _
   & "checked for duplicates?", Title:="Please select single column", Type:=8)
 Loop Until ColToCheck.Columns.Count = 1
 
'Begin the process of removing duplicates by loading unique values into string array
' and setting the duplicate rows into a range to delete later on
 UniqCount = 0
 ReDim UniqCells(0)
 For i = 1 To CheckRG.Rows.Count
  If Not InSArray(UniqCells, Intersect(CheckRG.Rows(i).EntireRow, ColToCheck).Text) Then
   ReDim Preserve UniqCells(UniqCount)
   UniqCells(UniqCount) = Intersect(CheckRG.Rows(i).EntireRow, ColToCheck).Text
   UniqCount = UniqCount + 1
  Else
   If DelRG Is Nothing Then
    Set DelRG = CheckRG.Rows(i).EntireRow
   Else
    Set DelRG = Union(DelRG, CheckRG.Rows(i).EntireRow)
   End If
  End If
 Next i
   
'Delete duplicate rows
 If Not DelRG Is Nothing Then 'If there are duplicate cells...
  Application.ScreenUpdating = False 'Turn off screen updating
  DelRG.Delete 'Delete duplicate range
  Application.ScreenUpdating = True 'Turn on screen updating
 End If

End Sub

Function InSArray(ByRef vArray() As String, ByVal vValue As String) As Boolean
 Dim i As Long
 For i = LBound(vArray) To UBound(vArray)
  If vArray(i) = vValue Then
   InSArray = True
   Exit Function
  End If
 Next i
 InSArray = False
End Function

You could also look at "The Duplicate Master", a free excel add-in created by EE's own brettdj: http://members.iinet.net.au/~brettdj

Matt
0
 
PSSUserCommented:
You could make use of the AutoFilter and a formula:

OutCol =  InputBox("Which column should be" & vbNewLine & "used for the formula?", "Not so fast...","B")
ChkCol = InputBox("Which column should be" & vbNewLine & "checked for duplicates?", "Not so fast...","A")

Do While Cells((lngEnd + 1), 1) <> ""
   lngEnd = lngEnd + 1
Loop

Range(OutCol & "2").Formula = "=IF(" & ChkCol & "2=" & ChkCol & "1,""Y"",""N"")"
Range(OutCol & "2").Select
Selection.AutoFill Destination:=Range(OutCol & "2:" & OutCol & lngEnd ), Type:=xlFillDefault
Cells.Select
Selection.AutoFilter Field:=Range(OutCol & "2").Column, Criteria1:="Y"
Rows("2:" & lngEnd).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
0
 
dmangCommented:
LastRow is a function that will return the last row number of the last row on the worksheet that contains any data (including spaces).

Using your code, with a slight change...
lngend = lastrow(activesheet)

'   Begin the process of removing duplicates
    For lngRow = lngend to 2 step -1
        If Cells(lngRow-1, lngColumn) = Cells(lngRow, lngColumn) Then
            Rows(lngRow).Select
            Selection.Delete
        End If
    Next lngRow


Function LastRow(ws As Worksheet) As Single

    'uses worksheet object
    'returns last used row
 
    On Error Resume Next
   
    With ws
      LastRow = .Cells.Find(What:="*", _
        SearchDirection:=xlPrevious, _
        SearchOrder:=xlByRows).Row
    End With
 
End Function
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.