Using Excel VBA to delete duplicate rows of data

Posted on 2005-04-28
Medium Priority
Last Modified: 2008-01-09
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.

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
'   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
            lngRow = lngRow - 1
        End If
    Next lngRow

'   Turn on screen updating
    Application.ScreenUpdating = True

Exit Sub
Application.ScreenUpdating = True
MsgBox "Operation canceled by user.", vbInformation Or vbOKOnly, "Canceled"

End Sub




Question by:heath9916
LVL 35

Accepted Solution

mvidas earned 500 total points
ID: 13886855
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
  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
   If DelRG Is Nothing Then
    Set DelRG = CheckRG.Rows(i).EntireRow
    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

LVL 10

Expert Comment

ID: 13887359
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

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
Selection.AutoFilter Field:=Range(OutCol & "2").Column, Criteria1:="Y"
Rows("2:" & lngEnd).Select
Selection.Delete Shift:=xlUp

Expert Comment

ID: 13936206
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
        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, _
    End With
End Function

Featured Post


Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses

850 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question