Delete duplicate row but keep the one with highest number in the cell next to.

R

Rob*

Board Regular
Joined
Apr 23, 2010
Messages
82
As I tried to explain very short in the title. I want to delete rows that has duplicates but still keep the row with higest number from a cell in the column next to the one being searched for duplicates.

Code: 
 Looks like this, but I have thousands of rows. 
Where I have about 500 to 1000 uniqe numbers.
 
  |  A  |   B   |
1 | 680 | 832122 <--- Delete
2 | 682 | 832441 <--- Delete
3 | 703 | 832122 <--- Delete
4 | 703 | 832442 <--- Delete
5 | 713 | 832443 <--- Delete
6 | 800 | 832122 <--- Keep
7 | 855 | 832441 <--- Delete
8 | 890 | 832441 <--- Keep
9 | 999 | 832442 <--- Keep
So, I wanna delete duplicates in column B but keep the row with the highest value in column A
Is it possible to make a cute little macro that solves this for me?
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
Try...

Code: 
Option Explicit

Sub DeleteDuplicates()

    Dim LastRow As Long
    Dim i As Long

    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    For i = LastRow To 1 Step -1
        If Cells(i, "A").Value <> Application.Evaluate("MAX(IF(" & Range(Cells(1, "B"), Cells(LastRow, "B")).Address _
            & "=" & Cells(i, "B").Address & "," & Range(Cells(1, "A"), Cells(LastRow, "A")).Address & "))") Then
            Rows(i).Delete
        End If
    Next i
    
    Application.ScreenUpdating = True
         
End Sub
 
Last edited:
Upvote 0
If the range is large then consider using a filter because it deletes them in one hit. Test this on a copy of your sheet first. It assumes that you have column labels / field names in row 1 so you may need to insert the row and give it field names.
Code: 
[COLOR="Blue"]Public[/COLOR] [COLOR="Blue"]Sub[/COLOR] DelDupes()
    [COLOR="Blue"]Dim[/COLOR] rngFilter [COLOR="Blue"]As[/COLOR] Range
    [COLOR="Blue"]Dim[/COLOR] rngCriteria [COLOR="Blue"]As[/COLOR] Range
    
    [COLOR="Blue"]With[/COLOR] ActiveSheet
        [COLOR="Blue"]Set[/COLOR] rngFilter = Application.Intersect(.UsedRange, .Range("A:B"))
        [COLOR="Blue"]Set[/COLOR] rngCriteria = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(2)
    [COLOR="Blue"]End[/COLOR] [COLOR="Blue"]With[/COLOR]
    
    rngCriteria.Resize(1).Offset(1).Formula = "=COUNTIF($B$2:B2,B2)>1"
    [COLOR="Blue"]With[/COLOR] rngFilter
        .Sort key1:=rngFilter.Resize(1, 1), order1:=xlDescending, header:=xlYes
        .AdvancedFilter action:=xlFilterInPlace, criteriarange:=rngCriteria
        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .Parent.ShowAllData
    [COLOR="Blue"]End[/COLOR] [COLOR="Blue"]With[/COLOR]
    rngCriteria.Clear
[COLOR="Blue"]End[/COLOR] [COLOR="Blue"]Sub[/COLOR]

P.S not sure why you want to delete the 5th item - it is unique.
 
Upvote 0
I too had the same problem and I found an easy non-VB way to accomplish this.

Where Column X contained my unique ID (duplicates) and Y contained my criteria (large to small values), I sorted first by Column X (any order) then by Column Y (Descending)... then I wrote the following formula into cell Z2 (Z is a temporary column):
Code: 
=IF(AND(X2=X1,Y2<=Y1),"Dup","Keep")

You can copy this formula down as many rows as you need (I did it for 35,000). Change the references to suit your code.

In plain english this formula would read: If the unique ID value from the current row matches the unique ID value from the previous row AND the criteria from the current row is less than or equal to that of the previous row, Excel will let me know that it is a duplicate/worthless entry.

Hope this helps someone.
 
Upvote 0
I need to delete duplicate rows in the "Description" column but keep the highest number in the "Order" column. In addition, I need to combine the duplicate amounts for (Budget, Commit, PTD, Avail) into the one line item that is left after removing the duplicates. This is what the spreadsheet would look like initially:
Order DescriptionBudgetCommitPTDAvail
90Road 4580205010
100Road 4580205010
90House 40080205010
100House 40080205010
90Site 28280205010
100Site 28280205010
This is what I want the spreadsheet to look like after removing duplicates:


Order DescriptionBudgetCommitPTDAvail
100Road 451604010020
100House 4001604010020
100Site 2821604010020

<tbody>
</tbody><colgroup><col><col><col span="4"></colgroup>

<tbody>
</tbody><colgroup><col><col><col span="4"></colgroup>
 
Upvote 0
colinr1 said:
I too had the same problem and I found an easy non-VB way to accomplish this.

Where Column X contained my unique ID (duplicates) and Y contained my criteria (large to small values), I sorted first by Column X (any order) then by Column Y (Descending)... then I wrote the following formula into cell Z2 (Z is a temporary column):
Code: 
=IF(AND(X2=X1,Y2<=Y1),"Dup","Keep")

You can copy this formula down as many rows as you need (I did it for 35,000). Change the references to suit your code.

In plain english this formula would read: If the unique ID value from the current row matches the unique ID value from the previous row AND the criteria from the current row is less than or equal to that of the previous row, Excel will let me know that it is a duplicate/worthless entry.

Hope this helps someone.
Click to expand...

Thanks mate, this works like magic! Bless
 
Upvote 0
John, while I realize this post is 7 years old I am hopeful that you can still help me. Your code works great when there are only 2 columns of data but I have 14 columns (A:N) and something is causing it to delete the row with the highest number instead of the lowest. The data being compared is in columns D and E. I think it is in the sort but being a VBA novice I just cannot figure this out. My code is below and thanks in advance for your help.

Code: 
Public Sub DelDupes()
    Dim rngFilter As Range
    Dim rngCriteria As Range

    With ActiveSheet
    
         ActiveSheet.Name = "Working Copy"
         ActiveSheet.Copy Before:=Sheets(1)      '### take a copy of our active sheet so we don't touch the original data
         ActiveSheet.Name = "Master"
         Sheets("Working Copy").Activate
         Range("E1").EntireColumn.Insert
         Cells(1, 5) = "Unique Key"
            
            Row = 2                                 '### the following While loop concatenates Cond Type & VarKey into column "E"
            While (Cells(Row, 2) <> "")
            Cells(Row, 5) = Cells(Row, 1) & Cells(Row, 8)
            Row = Row + 1
            Wend
         
         Columns("A:Z").EntireColumn.AutoFit
         
        Set rngFilter = Application.Intersect(.UsedRange, .Range("A:N"))
        Set rngCriteria = Cells(4, Columns.Count).End(xlToLeft).Offset(, 1).Resize(2)
        
    End With
    
    rngCriteria.Resize(1).Offset(1).Formula = "=COUNTIF($E$2:E2,E2)>1"
    
    With rngFilter
        .Sort key1:=rngFilter.Resize(1, 1), order1:=xlDescending, Header:=xlYes
        .AdvancedFilter Action:=xlFilterInPlace, criteriarange:=rngCriteria
        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .Parent.ShowAllData
    End With
    
    rngCriteria.Clear
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Delete duplicate rows while keeping the largest value and smallest value corresponding to the same name
Replies
4
Views
153
sofas
S
A
  • Solved
Remove Duplicates - first instance
Replies
8
Views
723
JoeMo
J
H
  • Question
VBA to remove duplicate rows based on date in other column
2
Replies
11
Views
1K
harieta
H
K
  • Question
VBA to delete duplicate rows but save the one with the highest value.
Replies
3
Views
486
Peter_SSs
Peter_SSs
R
  • Question
VBA count duplicates based on column then delete duplicate, but keep one
Replies
1
Views
984
Marc L
Marc L

Forum statistics

Threads
1,215,042
Messages
6,122,810
Members
449,095
Latest member
m_smith_solihull

Share this page

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