Removing duplicates in an array

[EdStockton]

Hello everyone,

I am attempting to remove duplicates in three columns individually. The data is a trial balance on a sheet entitled TB. I am selecting columns A, B, and C and copying those columns to a new sheet called Criteria. Once I get the columns to Criteria, I need to remove the duplicates in each column individually. It works except for the last column. My trial balance is about 500 rows so for my example shown here I will display only a few rows. My code is as follows:

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+z
'
Sheets("Sheet1").Select
Sheets("Sheet1").Copy Before:=Sheets(1)
Sheets("Sheet1 (2)").Select
Sheets("Sheet1 (2)").Name = "Criteria"
Application.GoTo ActiveWorkbook.Sheets("TB").Cells(1, 1)
ActiveSheet.Range("a1", ActiveSheet.Range("a1").End(xlDown)).Select
Selection.Copy
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 1)
ActiveSheet.Paste
Application.CutCopyMode = False
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 1)
OnlyColumnA
Application.GoTo ActiveWorkbook.Sheets("TB").Cells(1, 2)
ActiveSheet.Range("b1", ActiveSheet.Range("b1").End(xlDown)).Select
Selection.Copy
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 2)
ActiveSheet.Paste
Application.CutCopyMode = False
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 2)
OnlyColumnB
Application.GoTo ActiveWorkbook.Sheets("TB").Cells(1, 3)
ActiveSheet.Range("c1", ActiveSheet.Range("c1").End(xlDown)).Select
Selection.Copy
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 3)
ActiveSheet.Paste
Application.CutCopyMode = False
Application.GoTo ActiveWorkbook.Sheets("Criteria").Cells(1, 3)
OnlyColumnC
End Sub
Sub OnlyColumnA()
Dim n As Long

n = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Range("A1:A" & n).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
Sub OnlyColumnB()
Dim m As Long

m = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range("B1:B" & m).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
Sub OnlyColumnC()
Dim p As Long

p = Cells(Rows.Count, "C").End(xlUp).Row
ActiveSheet.Range("C1:C" & p).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

When I run this, I still have duplicates in column C. The data I am using is of this nature:

Property	PropType	PropNum
Bond0000	Bond	0000
OPCP0000	OPCO	0000
OPMA0000	OPMA	0000
CFP0000	CFP	0000
RHF0000	RHF	0000
Bond1001	Bond	1001
OPCO1001	OPCO	1001
OPMA1001	OPMA	1001
CFP1001	CFP	1001
RHF1001	RHF	1001
Bond1005	Bond	1005
OPCO1005	OPCO	1005
OPMA1005	OPMA	1005
CFP1005	CFP	1005
RHF1005	RHF	1005
Bond1007	Bond	1007
OPCO1007	OPCO	1007
OPMA1007	OPMA	1007
CFP1007	CFP	1007
RHF1007	RHF	1007

<tbody>
</tbody>

<strike></strike>

<strike></strike>When the process is finished it should look like this:

Property	PropType	PropNum
Bond0000	Bond	0000
OPCP0000	OPCO	1001
OPMA0000	OPMA	1005
CFP0000	CFP	1007
RHF0000	RHF
Bond1001
OPCO1001
OPMA1001
CFP1001
RHF1001
Bond1005
OPCO1005
OPMA1005
CFP1005
RHF1005
Bond1007
OPCO1007
OPMA1007
CFP1007
RHF1007

<tbody>
</tbody>

Instead it looks like this:

Property	PropType	PropNum
Bond0000	Bond	0000
OPCP0000	OPCO	0000
OPMA0000	OPMA	0000
CFP0000	CFP	0000
RHF0000	RHF	0000
Bond1001		0000
OPCO1001		0000
OPMA1001		0000
CFP1001		0000
RHF1001		0000
Bond1005		0000
OPCO1005		0000
OPMA1005		0000
CFP1005		0000
RHF1005		0000
Bond1007		0000
OPCO1007		0000
OPMA1007		0000
CFP1007		0000
RHF1007		0000

<tbody>
</tbody>

I would really appreciate your help.

Thanks, Ed

 

[MickG]

Try this :-
From sheets "TB" to "Criteria"

[COLOR="Navy"]Sub[/COLOR] MG06Jun22
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
Ray = Sheets("Tb").Cells(1).CurrentRegion
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
ReDim nRay(1 To UBound(Ray, 1), 1 To 3)
[COLOR="Navy"]For[/COLOR] ac = 1 To 3
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
        Dic(Ray(n, ac)) = Empty
    [COLOR="Navy"]Next[/COLOR]
        [COLOR="Navy"]With[/COLOR] Sheets("Criteria").Cells(1, ac).Resize(Dic.Count)
            .Value = Application.Transpose(Dic.keys)
            .Parent.Range("C:C").NumberFormat = "@"
        [COLOR="Navy"]End[/COLOR] With
        Dic.RemoveAll
[COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[EdStockton]

MickG,

Thank you so much. It worked perfect the first time.