Macro for deleting duplicate rows if four criteria match

[Kirstym1918]

Hi all,

I'm just wondering if anyone could help with a macro code I could use on a spreadsheet I have been working on. I have managed to compile just about everything I need to the spreadsheet except for this issue. I download data of orders on a daily basis and paste into each daily tab which then works out the info from formulas on another sheet which saves a lot of manual input time. My issue is that I only need one line of each order but the spreadsheet I paste has each part of the order so some have up to 5 parts, my formulas are then counting this as 5 orders as oppose to one.

I have four columns that the macro can look at, if it finds duplicates in all 4 columns I want to it remove duplicate rows leaving only one in place

I need the macro to look at columns B, E, F & G

Would anyone be so kind to help?

Many Thanks

 

[Kaper]

If you use reasonably recent version of excel, you have a tool to delete duplicates built in. See Data Ribbon - Data Tools group.

sub test()
Range("A1:G" & cells(rows.count,"A").end(xlup).row).RemoveDuplicates Columns:=Array(2, 5, 6, 7),  Header:=xlYes
end sub

 

[MickG]

Try this:-
This code removes rows where there are duplicate rows based on columns B,E,F & G.

[COLOR="Navy"]Sub[/COLOR] MG09Mar24
[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] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & 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 = Join(Application.Index(Dn.EntireRow, Array(2, 5, 6, 7)), ",")
            [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
                .Add Txt, Nothing
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Kirstym1918]

Thanks Kaper, This worked perfectly, you learn something new everyday

 

[Kirstym1918]

Thanks very much Mick, I will try my hand at a macro even though I've never attempted one before, wish me luck

 

[MickG]

You're welcome