VBA finding duplicates and taking lowest value

[bergen]

Having tried for hours to work out the solution myself I am throwing in the towel, can anyone please help me out? I will be doing this many times so would like to avoid using pivot table and copy paste from that.

So I am trying to use VBA to go through a document and delete all duplicate rows with a high number

My data looks like this (hundres of rows):
[TABLE="width: 500"]
<tbody>[TR]
[TD]Part Number
[/TD]
[TD]Price
[/TD]
[/TR]
[TR]
[TD]20040
[/TD]
[TD]1500
[/TD]
[/TR]
[TR]
[TD]20038
[/TD]
[TD]1000
[/TD]
[/TR]
[TR]
[TD]20038
[/TD]
[TD]1300
[/TD]
[/TR]
[TR]
[TD]20034
[/TD]
[TD]4000
[/TD]
[/TR]
[TR]
[TD]20040
[/TD]
[TD]3000
[/TD]
[/TR]
[TR]
[TD]20040
[/TD]
[TD]1200
[/TD]
[/TR]
</tbody>[/TABLE]

The macro should then return a document that will look like this: (having deleted all rows with high values on duplicates, but retained low values on duplicates and non-duplicates)

[TABLE="width: 500"]
<tbody>[TR]
[TD]Part Number
[/TD]
[TD]Price
[/TD]
[/TR]
[TR]
[TD]20040
[/TD]
[TD]1200
[/TD]
[/TR]
[TR]
[TD]20038
[/TD]
[TD]1000
[/TD]
[/TR]
[TR]
[TD]20034
[/TD]
[TD]4000
[/TD]
[/TR]
</tbody>[/TABLE]

There must be a way to do this?

 

[Jim885]

Try this;

Sub delDup()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(1)
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    With Columns("A:B")
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B" & lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:B" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End With
    ActiveSheet.Range("A1:B" & lr).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[bergen]

Thanks Jim! This is great stuff but I just have one issue with this code and that is the fact that my data will be reordered, is there anyway to do this without reordering the rows? Or to put them back in original order before the sub ends?

 

[Jim885]

OK.
The code has to put the duplicates together, then sort them in order to delete the higher values.

It seems that your original data is random, while your desired output is DESCENDING. My first code did the output as ASCENDING.

Here's a small variation that will put the Part# output data as DESCENDING while still deleting the higher values, and leaving the lowest value for each part number. (Hopefully what you want)

If this is not what you want, perhaps someone else could try. I know of no other way to accomplish this.

Sub DelHighValueDups()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(1)
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
  With Columns("A:B")
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:B" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  End With
    ActiveSheet.Range("A1:B" & lr).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[bergen]

Hi Jim I really appreciate the help. But I wanted to keep the data in the original order (in the real life data the product codes are subdivided into different product groups that are just titled = not numerical or alphabetical).
If anyone has a suggestion for how to achieve what Jim has managed without the reordering it would be great, otherwise this will allow me to do what I need without too much trouble.

Thanks

 

[Jim885]

Hi Jim I really appreciate the help. But I wanted to keep the data in the original order (in the real life data the product codes are subdivided into different product groups that are just titled = not numerical or alphabetical).
If anyone has a suggestion for how to achieve what Jim has managed without the reordering it would be great, otherwise this will allow me to do what I need without too much trouble.

Thanks

If you are dealing with titles (text) rather than numerical (as in your example), I suggest that you provide real-life (similar) data to what you really have, so as not to receive wrong answers or waste someone's time with examples that are not relative to your situation. That does make a big difference.

 

[janderson055]

Here is something that should do the trick. I'm no VBA expert but with the small amount of data you provided this gave the desired result. You'll obviously have to change cell and column references to fit your spreadsheet.

Sub removeHighDuplicates()    Dim rowCounter As Integer
    Dim rowCounter2 As Integer
    Dim partNumber As String '''change as needed
    Dim partPrice As Integer '''change as needed
    
    rowCounter = 2 ''where your data starts
    rowCounter2 = 2 ''where your data starts
    
    Do Until Sheets(1).Cells(rowCounter, 1).Value = Empty
        partNumber = Sheets(1).Cells(rowCounter, 1).Value
        partPrice = Sheets(1).Cells(rowCounter, 2).Value
        rowCounter2 = 2
        Do Until Sheets(1).Cells(rowCounter2, 1).Value = Empty


            If Sheets(1).Cells(rowCounter2, 1).Value = partNumber And Sheets(1).Cells(rowCounter2, 2).Value > partPrice Then
                Rows(rowCounter2).Delete
                rowCounter2 = rowCounter2 - 1
            ElseIf Sheets(1).Cells(rowCounter2, 1).Value = partNumber And Sheets(1).Cells(rowCounter2, 2).Value < partPrice Then
                Rows(rowCounter).Delete
                rowCounter = rowCounter - 1
                rowCounter2 = rowCounter2 - 1
            End If
            rowCounter2 = rowCounter2 + 1
        Loop
        
        rowCounter = rowCounter + 1
    Loop
    
End Sub

Edit: Looks like this still needs some work, if you have some sample data to test out that would definitely help out.

 

[janderson055]

This should do the trick. It starts at the first entry and loops through everything in the list, assuming that there aren't any blanks in the list. If it finds a row with the same part number but has a higher value, it deletes that row. If it finds a row with the same part number but lower price, it deletes the row it was checking against. Lastly if it finds a row with the same part number and same price, it deletes that row.

Sub removeHighDuplicates()
    Dim rowCounter As Integer
    Dim rowCounter2 As Integer
    Dim partNumber As String '''change as needed
    Dim partPrice As Integer '''change as needed
    
    rowCounter = 2 ''where your data starts
    rowCounter2 = 2 ''where your data starts
    
    Do Until Sheets(1).Cells(rowCounter, 1).Value = Empty
        partNumber = Sheets(1).Cells(rowCounter, 1).Value
        partPrice = Sheets(1).Cells(rowCounter, 2).Value
        rowCounter2 = 2
        Do Until Sheets(1).Cells(rowCounter2, 1).Value = Empty
            If rowCounter < 2 Then
                rowCounter = 2
            End If
            
            If rowCounter = rowCounter2 Then
                rowCounter2 = rowCounter2 + 1
            ElseIf Sheets(1).Cells(rowCounter2, 1).Value = partNumber And Sheets(1).Cells(rowCounter2, 2).Value > partPrice Then
                Rows(rowCounter2).Delete
                rowCounter2 = rowCounter2 - 1
            ElseIf Sheets(1).Cells(rowCounter2, 1).Value = partNumber And Sheets(1).Cells(rowCounter2, 2).Value = partPrice Then
                Rows(rowCounter2).Delete
                rowCounter2 = rowCounter2 - 1
            ElseIf Sheets(1).Cells(rowCounter2, 1).Value = partNumber And Sheets(1).Cells(rowCounter2, 2).Value < partPrice Then
                Rows(rowCounter).Delete
                rowCounter = rowCounter - 1
                rowCounter2 = rowCounter2 - 1
                Exit Do
            End If
            rowCounter2 = rowCounter2 + 1
        Loop
        
        rowCounter = rowCounter + 1
    Loop
    
End Sub

 

[bergen]

Thank you a bunch Janderson that works nicely!

And apologies for "misleading" with my example, just thought it would be easier with simple data rather than real data, lesson learned.