VBA - Remove duplicate rows (based on 1st 3 columns) but leave last entry...

[RobbieC]

Hi there, I have a Worksheet filled with data to column P. All columns have various data in, but the first 3 are the important ones (A, B & C)

I'm looking to write a bit of VBA to scan columns A, B & C and remove any duplicate rows (rows D to P will all have different data - it is only A B & C which will match)

So the end result is to leave the final entry, but delete all previous rows...

If you can point me in the right direction, I'd be very grateful - it's been bugging me all day

Thanks very much

Rob

 

[jmacleary]

Hi Robbie
Try this code: (it assumes you have headers in row 1 and data starts row2):

Sub RobbieC()
    Dim Answer As String
    Dim OneRow As Long
    Dim OneValue As String
    Dim LastRow As Long
' NB Microsoft scripting Runtime must be enabled'  
    Dim AllRows As New Scripting.Dictionary
    LastRow = Range("A65536").End(xlUp).Row

    For OneRow = LastRow To 2 Step -1
' tilde character inserted between columns so mismatches are much less likely
        OneValue = Cells(OneRow, 1).Value & "~" & Cells(OneRow, 2).Value & "~" & Cells(OneRow, 3).Value
        If AllRows.exists(OneValue) Then
            Cells(OneRow, 1).EntireRow.Delete
        Else
            AllRows(OneValue) = 1
        End If
    Next

End Sub

You will need to turn on Scripting Runtime. Go to the VB editor and paste this code into a new module. Then select Tools, References and scroll down to Microsoft Scripting Runtime. Click the select box and then OK.

 

[jkpieterse]

A manual method:
When deleting duplicates, Excel keeps the first and deletes the others. SO the process of keeping the last one is:
- Add a column with increasing numbers
- Sort table on the new column in Descending order
- Remove duplicates only checking columns A, B and C
- Sorting the table on the index column in ascending order to restore the sort order

In VBA code:

Sub KeepLastDuplicate()
    Dim Rng As Range
    Set Rng = ActiveSheet.UsedRange
    With Rng
        .Offset(0, .Columns.Count).Resize(, 1).Formula = "=row()"
        .Offset(0, .Columns.Count).Resize(, 1).Value = .Offset(0, .Columns.Count).Resize(, 1).Value
    End With
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Intersect(ActiveSheet.UsedRange, Range("Q:Q")), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange ActiveSheet.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Intersect(ActiveSheet.UsedRange, Range("Q:Q")), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange ActiveSheet.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("Q:Q").EntireColumn.Delete
End Sub

 

[Peter_SSs]

Another possible vba approach:

Sub Keep_Last()
  Dim lr As Long
  
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Range("Z2").Formula = Replace("=COUNTIFS(A2:A$#,A2,B2:B$#,B2,C2:C$#,C2)>1", "#", lr)
  With Range("A1:P" & lr)
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("Z1:Z2"), Unique:=False
    .Offset(1).EntireRow.Delete
  End With
  On Error Resume Next
  ActiveSheet.ShowAllData
End Sub

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version.

 

[RobbieC]

Thanks for your ideas guys

jmacleary - this method with Microsoft Runtime Scripting made the formula bar flash after the code was run... my workbook abviously didn't like it

jkpieterse -

ActiveSheet.Sort.SortFields.Add2 Key:=Intersect(ActiveSheet.UsedRange, Range("Q:Q")), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal

this line keeps throwing an error, but I caan't see why...

Peter_SSs - your code works however, my sheet has the first 3 rows which need to remain unaltered (thought this wouldn't matter, but obviously it does). For some reason it always deletes the 3rd row and only works when the sheet is ACTIVE (I really need the code to run in the background without activating Sheets("datasheet") ).
I've tried to alter the code so that it references the worksheet Sheets("datasheet") and also replacing 2's with 4's but can't get it to work...

Thanks again for your help - I'll keep tweaking this end

 

[Peter_SSs]

my sheet has the first 3 rows which need to remain unaltered (thought this wouldn't matter, but obviously it does). For some reason it always deletes the 3rd row and only works when the sheet is ACTIVE (I really need the code to run in the background without activating Sheets("datasheet") ).
I've tried to alter the code so that it references the worksheet Sheets("datasheet") and also replacing 2's with 4's but can't get it to work...

See how this goes.

Sub Keep_Last_v2()
  Dim lr As Long
  
  With Sheets("datasheet")
    lr = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Range("Z2").Formula = Replace("=COUNTIFS(A4:A$#,A4,B4:B$#,B4,C4:C$#,C4)>1", "#", lr)
    With .Range("A3:P" & lr)
      .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("Z1:Z2"), Unique:=False
      .Offset(1).EntireRow.Delete
    End With
    .Range("Z2").ClearContents
    On Error Resume Next
    .ShowAllData
  End With
End Sub

 

[jkpieterse]

My code errors if the sheet only contains data up to and including column O. It then tries to add the counter to column P so the Q:Q must be replaced with P:P.