Find Duplicates in column B + column C and the delete rows that have lowest value in column L

almulder

New Member
Joined
Jun 19, 2018
Messages
3
I need to find a way to find duplicate values of two column, but let me explain a bit more

In column B i have a list of invoices and column c is the line number of an invoice. then in column L i have the value

I have records where there are duplicate invoices(b) and lines(c) but the value(L) is different

Example:
(B) (C) (L)
1957286 1 9.45
1957286 2 1.33
1957286 3 1.33
1957286 4 1.05
1957286 6 49.92
1957286 7 7.00
1957286 7 7.00
1957286 7 9.80
1957286 7 20.30
1957286 7 29.50
1957286 7 38.50


As you can see there is invoice(B) 1957286 and line(C) 7 duplicated 6 times, I would need to delete 5 of them leaving the highest value(L) 38.50

so the report would look like this afterwards
Example:
(B) (C) (L)
1957286 1 9.45
1957286 2 1.33
1957286 3 1.33
1957286 4 1.05
1957286 6 49.92
1957286 7 38.50

I have 1000's of rows every month I have to do this with, everyone else has been doing it manually, I want to automate it and save hours of work.

Thanks for your help.

Maybe make a 2 step process if possible where it highlights the rows it wants to delete, and then after quick manual review and verified that is correct it deletes them?
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
almulder,

Welcome to the Board.

You might consider the following...

Code:
Sub RemoveDups_1059994()
Dim arr As Variant, arrNew() As Variant, nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim tmp As Long
Dim rng As String

With ActiveSheet.UsedRange
    rng = .Address
    arr = .Value
End With

nr = UBound(arr, 1)
nc = UBound(arr, 2)

ReDim arrNew(1 To nr, 1 To nc)
rNew = 0

For r = 1 To nr
    If r + 1 > nr Then Exit For
    tmp = arr(r, 2) & arr(r, 3)
    If arr(r + 1, 2) & arr(r + 1, 3) <> tmp Then
        rNew = rNew + 1
        For c = 1 To nc
            arrNew(rNew, c) = arr(r, c)
        Next c
    End If
Next r
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Range(rng).Value = arrNew
End Sub

Given your sample data, it's assumed Columns B, C and L are sorted in ascending order.

Cheers,

tonyyy
 
Upvote 0
Thanks tonyyy, however it looks like there is an issue

Run-time error '13
Type mismatch

its on this line
Code:
tmp = arr(r, 2) & arr(r, 3)




almulder,

Welcome to the Board.

You might consider the following...

Code:
Sub RemoveDups_1059994()
Dim arr As Variant, arrNew() As Variant, nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim tmp As Long
Dim rng As String

With ActiveSheet.UsedRange
    rng = .Address
    arr = .Value
End With

nr = UBound(arr, 1)
nc = UBound(arr, 2)

ReDim arrNew(1 To nr, 1 To nc)
rNew = 0

For r = 1 To nr
    If r + 1 > nr Then Exit For
    tmp = arr(r, 2) & arr(r, 3)
    If arr(r + 1, 2) & arr(r + 1, 3) <> tmp Then
        rNew = rNew + 1
        For c = 1 To nc
            arrNew(rNew, c) = arr(r, c)
        Next c
    End If
Next r
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Range(rng).Value = arrNew
End Sub

Given your sample data, it's assumed Columns B, C and L are sorted in ascending order.

Cheers,

tonyyy
 
Upvote 0
Is there anything in Column A? Or is it completely blank?

Are Columns B and C strictly numeric?

Is there a header row?

(Based on your data sample, I assumed data in Column A and no header row.)
 
Upvote 0
Another option !!!
This code will delete rows not required !!!
NB:- Data assumed to start B2.
Code:
[COLOR="Navy"]Sub[/COLOR] MG20Jun55
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Delrng [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
        .Add txt, Dn.Offset(, 10)
    [COLOR="Navy"]Else[/COLOR]
       [COLOR="Navy"]If[/COLOR] .Item(txt) >= Dn.Offset(, 10) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn.Offset(, 10) Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn.Offset(, 10))
       [COLOR="Navy"]ElseIf[/COLOR] Dn.Offset(, 10).Value >= .Item(txt) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = .Item(txt) Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, .Item(txt))
           [COLOR="Navy"]Set[/COLOR] .Item(txt) = Dn.Offset(, 10)
       [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
tonyyy - Yes there is a header sorry. I removed the header and tested it and it looks like it missed 1 line, not sure why but got 303 lines moved

MickG - Your code works got 305 lines including header and that matched my manual review of last months data I did. (line for line match to mine) :)


Thank you both very much for your help, when I have time this weekend I plan on reviewing the code to see if I can understand whats going on and try to learn a little.



Is there anything in Column A? Or is it completely blank?

Are Columns B and C strictly numeric?

Is there a header row?

(Based on your data sample, I assumed data in Column A and no header row.)

Another option !!!
This code will delete rows not required !!!
NB:- Data assumed to start B2.
Code:
[COLOR=Navy]Sub[/COLOR] MG20Jun55
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Delrng [COLOR=Navy]As[/COLOR] Range, nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] txt [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR=Navy]If[/COLOR] Not .Exists(txt) [COLOR=Navy]Then[/COLOR]
        .Add txt, Dn.Offset(, 10)
    [COLOR=Navy]Else[/COLOR]
       [COLOR=Navy]If[/COLOR] .Item(txt) >= Dn.Offset(, 10) [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = Dn.Offset(, 10) Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn.Offset(, 10))
       [COLOR=Navy]ElseIf[/COLOR] Dn.Offset(, 10).Value >= .Item(txt) [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = .Item(txt) Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, .Item(txt))
           [COLOR=Navy]Set[/COLOR] .Item(txt) = Dn.Offset(, 10)
       [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
This should accommodate the header and missing line...

Code:
Sub RemoveDups_1059994()
Dim arr As Variant, arrNew() As Variant, nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim tmp As Variant
Dim rng As String

With ActiveSheet.UsedRange
    rng = .Address
    arr = .Value
End With

nr = UBound(arr, 1) + 1
nc = UBound(arr, 2)

ReDim arrNew(1 To nr, 1 To nc)
rNew = 0

For r = 1 To nr
    If r + 1 = nr Then GoTo finish
    tmp = arr(r, 2) & arr(r, 3)
    If arr(r + 1, 2) & arr(r + 1, 3) <> tmp Then
        rNew = rNew + 1
        For c = 1 To nc
            arrNew(rNew, c) = arr(r, c)
        Next c
    End If
Next r
finish:
    rNew = rNew + 1
    For c = 1 To nc
        arrNew(rNew, c) = arr(r, c)
    Next c
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Range(rng).Value = arrNew
End Sub

But if it were me, I'd defer to MickG's code. :)

Cheers,

tonyyy
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,927
Members
448,533
Latest member
thietbibeboiwasaco

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