Need help to eliminate duplicate numbers in a column with a VBA

[skyport]

I was given a macro for this but it doesn't seem to work. Hopefully someone can help.

column A will contain a list of telephone numbers entered in this format: (xxx) yyy-zzzz which is how it would appear in the formula bar if the cell were selected. I need a macro that would eliminate all duplicates but the most important aspect would be to always retain the first entry of each unique number in column A and only eliminate any and all subsequent duplicate entries of same numbers.

Secondly, if possible, although not critical, would be to show in column C those duplicate numbers that were eliminated from column A when the Macro runs and leave column A with only unique numbers and no blank spaces between the entries.

Below is what I was given that doesn't seem to work and please note we need to use PC, Windows 7 and Excel 2000 for this.

Sub test()
ActiveSheet.Range("$A$1:$A$10").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

[Latchmaker]

Sub test()
ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub


Your Macro would only remove duplicates in the first 10 rows....the macro above removes all duplicates in Column A

 

[V_Malkoti]

Try this:

Public Sub SubFindDuplicates()
    Dim oCell As Range, oSource As Range, oPhoneColl As Object
    Dim arrKeys As Variant, arrVals As Variant
    
    Set oPhoneColl = CreateObject("Scripting.Dictionary")
    Set oSource = Sheets("[B][COLOR=#0000ff]Sheet1[/COLOR][/B]").Range("[B][COLOR=#0000ff]A1:A10[/COLOR][/B]")
    
    For Each oCell In oSource
        If oPhoneColl.Exists(oCell.Value) Then
            oPhoneColl.Item(oCell.Value) = oPhoneColl.Item(oCell.Value) + 1
        Else
            oPhoneColl.Add oCell.Value, 1
        End If
    Next
    
    arrKeys = oPhoneColl.Keys
    arrVals = oPhoneColl.Items
    
    oSource.Clear
    
    For i = 0 To oPhoneColl.Count - 1
        Cells(i + 1, 1).Value = arrKeys(i)
        If arrVals(i) > 1 Then Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = arrKeys(i)
    Next
End Sub

Modify highlighted parts if necessary.

 

[skyport]

Thanks to you both for helping me. The following were the results from trying both codes:

V_Malkoti - I adjusted the range using the idea supplied by Latchmaker to ("$A:$A") which allows it to cover the entire column and your code works absolutely perfect. Thanks so much.

Latchmaker - I ran the code as you adjusted the range and still I got the same error message when I tried the original which is below:

run-time error 438 Object doesn't support this property or method

However, as I mentioned, using your range suggestion in the V_Malkoti code, the whole problem is solved. I want to thank you both again for helping me. If you care to review or adjust the code you supplied and wish my feed back, I would be most happy to do that.

This forum is made great by help from people like yourselves. You both are greatly appreciated.

 

[V_Malkoti]

Glad we could help.