Repeat Remove Duplicates Across Column Pairs

[Tallonenx]

Hello All,

I have several column pairs of data.
Each is a pair of columns with Date + Event.

They go on in a table for 100s of rows and 100s of pairs of columns.

Here's just an example of two column pairs (keeping in mind other pairs would continue to the right --> and the columns themselves have way more entries:

[TABLE="width: 500"]
<tbody>[TR]
[TD]1/1/2001
[/TD]
[TD]AAAA
[/TD]
[TD]1/1/2001
[/TD]
[TD]AAA
[/TD]
[/TR]
[TR]
[TD]1/2/2001
[/TD]
[TD]BBBB
[/TD]
[TD]1/2/2001
[/TD]
[TD]AAA
[/TD]
[/TR]
[TR]
[TD]1/2/2001
[/TD]
[TD]BBBB
[/TD]
[TD]1/3/2001
[/TD]
[TD]AAA
[/TD]
[/TR]
[TR]
[TD]1/3/2001
[/TD]
[TD]BBBB
[/TD]
[TD]1/4/2001
[/TD]
[TD]FFF[/TD]
[/TR]
[TR]
[TD]1/4/2001
[/TD]
[TD]BBBB
[/TD]
[TD]1/5/2001
[/TD]
[TD]FFF
[/TD]
[/TR]
</tbody>[/TABLE]


Sometimes there are repeat entries, for ex in the red text area.

Right now I can remove duplicates manually
by selecting each column pair together and just clicking the remove duplicates button.

This works fine, but this is tedious.
Is there a way to automate remove duplicates
for each column pair on the entire sheet?

Any help is greatly appreciated!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG12Dec38
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
Application.ScreenUpdating = False
Lst = Cells("1", Columns.Count).End(xlToLeft).Column
[COLOR="Navy"]For[/COLOR] Ac = 1 To Lst [COLOR="Navy"]Step[/COLOR] 2
   [COLOR="Navy"]Set[/COLOR] Rng = Range(Cells(1, Ac), Cells(Rows.Count, Ac).End(xlUp))
 
    [COLOR="Navy"]For[/COLOR] n = Rng.Count To 1 [COLOR="Navy"]Step[/COLOR] -1
        [COLOR="Navy"]With[/COLOR] Cells(n, Ac)
            [COLOR="Navy"]If[/COLOR] Application.CountIf(Rng, .Value) > 1 [COLOR="Navy"]Then[/COLOR]
                .Resize(, 2).Delete shift:=xlUp
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Ac
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Tallonenx]

This appears to work, so thanks for the code.

However, when faced with large amounts of data it crashes excel....
Not sure what I can do to avoid that.


Thank you for your help though!

 

[Tallonenx]

I'm able to run much large processes without it freezing...

Maybe the problem with it freezing is that the code encounters blanks?

 

[Fluff]

Which of the 2 cols can be blank? the 1st, the 2nd or both?
Also what do you want to happen if there is a blank?

 

[MickG]

Try this :-
NB:- The Data is assumed to have row1 as header and actual data starts row2.

[COLOR="Navy"]Sub[/COLOR] MG28Dec07
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    Lst = Cells("1", Columns.Count).End(xlToLeft).Column
[COLOR="Navy"]For[/COLOR] ac = 1 To Lst [COLOR="Navy"]Step[/COLOR] 2
   [COLOR="Navy"]Set[/COLOR] Rng = Range(Cells(2, ac), Cells(Rows.Count, ac).End(xlUp))
     ReDim nRay(1 To Rng.Count, 1 To 2): c = 0
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dn.Value = vbNullString [COLOR="Navy"]Then[/COLOR]
        Txt = CDate(Dn.Value) & Dn.Offset(, 1).Value
            [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
                 c = c + 1
                 nRay(c, 1) = CDate(Dn.Value): nRay(c, 2) = Dn.Offset(, 1).Value
                 .Add Txt, Nothing
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]Next[/COLOR] Dn
    Rng.Resize(, 2).Value = vbNullString
    Rng(1).Resize(.Count, 2) = nRay
    .RemoveAll
[COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick