Delete duplicate rows if values are identical across multiple columns

sharky12345

Well-known Member
Joined
Aug 5, 2010
Messages
3,404
Office Version
  1. 2016
Platform
  1. Windows
I have a sheet with data across columns A:F - I'm trying to find a simple method using VBA to delete any duplicate rows, i.e. if there is more than 1 row with identical values across all columns then delete any row after the first.

Can anyone help?
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
You can get the code via the macro recorder :
• Select columns A:F
• Go to Data/Data Tools/Remove Duplicates/Select All/OK
 
Upvote 0
If your data can be sorted before removing duplicates, then I'd suggest including that in your macro otherwise RemoveDuplicates may fail.
Here is a simple example to demonstrate such failure.

If you don't want your data sorted first, post back for an alternative way to achieve your desired result.
 
Upvote 0
Hello Peter - thanks for the update.

I've just tried the suggestion from footoo and it works, (as I knew it would). However, ideally I don't want to sort the data first, so if you can suggestion an alternative then I would be very grateful.
 
Upvote 0
Is the original data in a particular order or sequence?
The sorting can, of course, be part of the macro.
 
Last edited:
Upvote 0
I agree that sorting could be part of the macro. If you want the remaining rows to retain their original order then your macro could fill the next column with numbers 1 to whatever row the data ends on, sort the original data by all of the original columns, remove duplicates, re-sort based on the added column, remove the added column values.

Here is a way that still involves an additional column and one sort, but that sort retains all the remaining rows in their original order.
Test in a copy of your workbook.
Code:
Sub Del_Dupes()
  Dim d As Object
  Dim a, b
  Dim nc As Long, i As Long, k As Long
  Dim s As String
 
  nc = Cells(1, Columns.Count).End(xlToLeft).Column + 1
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Range("A2", Range("F" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    s = Join(Application.Index(a, i, 0), "|")
    If d.exists(s) Then
      b(i, 1) = 1
      k = k + 1
    Else
      d(s) = 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,020
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top