Find duplicates numbers in selected columns but delete duplicates in one of those columns

[greegan]

Good morning,

I would like to do this with vba
I have column A listing phone numbers, I paste new list of phone numbers in columns C, E, and G.
I would like to find duplicates in columns A and C, and delete cells in column C, then
find duplicates in columns A, C, and E, removing cells only in column E, then
find duplicates in columns A, C, E and G, removing cells only from column G.

Could someone help me with this?

The way I do it now is cumbersome...
In the first step, I would conditional format the duplicates, sort column C by cell colour and delete these cells. With none of this automated.
I'm hoping someone could help out.

Thank you

-- g

 

[greegan]

This is an example of my change to the code with your changes and the columns I need to work with.
It looks like it works until I get a Run time error 9: Subscript out of range, highlighting

        Set rClear = Range(cols1(i + 1) & ActiveSheet.Rows.Count).End(xlUp)

Sub removeduplicates_CMS2CD()
    Dim r As Range, rCompare As Range, rClear As Range
    Dim x As Integer
    Dim c As Range
    Dim cols1
    Dim i As Integer
    For i = 0 To 2
        cols1 = Array("B", "N")
        Set r = Range(cols1(i) & ActiveSheet.Rows.Count).End(xlUp)
        Set r = Range(cols1(i) & "4", r)
        If rCompare Is Nothing Then
            Set rCompare = r
        Else
            Set rCompare = Union(rCompare, r)
        End If
        Set rClear = Range(cols1(i + 1) & ActiveSheet.Rows.Count).End(xlUp)
        Set rClear = Range(cols1(i + 1) & "4", rClear)
        For x = 1 To rCompare.Areas.Count
            For Each c In rClear
                If WorksheetFunction.CountIf(rCompare.Areas(x), c) > 0 Then
                    c.Clear
                End If
            Next
        Next
        For Each c In rClear
            If WorksheetFunction.CountIf(rClear, c) > 1 Then
                c.Clear
            End If
        Next
        rClear.Sort rClear, xlAscending
    Next
End Sub

I'm still getting a runtime error (same line) no matter how I modify it.

 

[BrianMH]

Change

For i = 0 To 2

to

For i = LBound(cols1) To UBound(cols1)

 

[greegan]

Good morning,
This is exactly what I needed, thank you.
There is one adjustment I do seem to need that wasn't initially thought of.
Can you add code to clear out numbers in both A and C (and others) if the length is less than 10?

-- g

 

[BrianMH]

Sub ClearTooShort(CompareRange As Range, Length As Long)
Dim c As Range
For Each c In CompareRange.Cells
    If Len(c) < Length Then c = ""
Next c
End Sub

Add that code to the module and then at the very end of the sub you already have (just before end sub) add the below line. You can change the number if your needs change in the future.

call ClearTooShort(rCompare,10)

 

[greegan]

Again, thank you for your help.
This makes a world of difference.
Thank you
-- g