Delete duplicate rows using Macros

[Dyumani]

hello friends,

I have created an Excel sheet in which I have to write a long list of item names and their corresponding details. There are several rows in my Microsoft Excel file that have the same or duplicate data. I want to keep only one copy of the data and delete all the unnecessary duplications. How can I do that using Macros ? Can anyone provide me the necessary information regarding same.....thnx

[Sam.D]

A duplicate row (also called a record) in a list is one where all values in the row are an exact match of all the values in another row.

To delete duplicate rows -

• First filter a list for unique rows
• Next delete the original list
• Finally replace it with the filtered list.

Note - The original list must have column headers.

[Eric B]

Here's the macro code for deleting duplicate rows for an Excel file

Macro Code -

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

This macro code will delete all the duplicate rows that appears more than once in an excel file.

[Sam.D]

Follow the instructions below -

1. Select all the rows, including the column headers, in the list you want to filter.
2. On the Data menu, point to Filter, and then click Advanced Filter.
3. In the Advanced Filter dialog box, click Filter the list, in place.
4. Select the Unique records only check box, and then click OK.
   The filtered list is displayed and the duplicate rows are hidden.
5. On the Edit menu, click Office Clipboard.
   The Clipboard task pane is displayed.
6. Make sure the filtered list is still selected, and then click Copy .
   The filtered list is highlighted with bounding outlines and the selection appears as an item at the top of the Clipboard.
7. On the Data menu, point to Filter, and then click Show All.
   The original list is re-displayed.
8. Press the DELETE key.
   The original list is deleted.
9. In the Clipboard, click on the filtered list item.
   The filtered list appears in the same location as the original list.

[rollapig]

Hi all,

This is my first post, so bear with me.

I am currently populating a whole lot of different/identical data to a worksheet and then using a concatenated string in front of all the different figures I am determining which ones are the same. However I now need to delete the duplicate rows (entire rows). I found this code on the net which was working perfectly as long as I had less than 50 columns of data, anything over and I will get the error:

Runtime error '1004':
Unable to get the countif property of the worksheetFunction class

The problem is that there could be hundreds of columns!

When I click debug, I get this piece of code
(If Application.WorksheetFunction.CountIf(RNG.Columns(1), V) > 1 Then
RNG.Rows(R).EntireRow.Delete) highlighted yellow. Written in red below!

Any help would be greatly appreciated. Would like to fix this code, as it vital for the next process in my code.


'Delete Duplicates of Column B

Sheets("Prices").Select
Range("B:B").Select
Dim R As Long
Dim N As Long
Dim V As Variant
Dim RNG As Range

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


Thanks

rollapig

[JAMES_911]

Hi rollapig,

To resolve this problem, save and close the workbook periodically while the copy process is occurring, as in the following sample code:

Sub CopySheetTest()
    Dim iTemp As Integer
    Dim oBook As Workbook
    Dim iCounter As Integer
    
    ' Create a new blank workbook:
    iTemp = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set oBook = Application.Workbooks.Add
    Application.SheetsInNewWorkbook = iTemp
    
    ' Add a defined name to the workbook
    ' that RefersTo a range:
    oBook.Names.Add Name:="tempRange", _
        RefersTo:="=Sheet1!$A$1"
            
    ' Save the workbook:
    oBook.SaveAs "c:\test2.xls"
    
    ' Copy the sheet in a loop. Eventually,
    ' you get error 1004: Copy Method of
    ' Worksheet class failed.
    For iCounter = 1 To 275
        oBook.Worksheets(1).Copy After:=oBook.Worksheets(1)
        'Uncomment this code for the workaround:
        'Save, close, and reopen after every 100 iterations:
        If iCounter Mod 100 = 0 Then
            oBook.Close SaveChanges:=True
            Set oBook = Nothing
            Set oBook = Application.Workbooks.Open("c:\test2.xls")
        End If
    Next
End Sub