Macro to check against Columns & Delete Duplicates

cjamps · #1 11-23-2017, 08:14 AM

I have an excel spreadsheet that has 4 columns of phone number. The first 3 are Home Phone, Cell Phone, Other Phone. The 4th column are phone numbers from a phone hotline of people that called in. I want to check the 4th column (numbers of people who had called in to the hotline) against the other 3 columns for duplicates. If the phone number already exists in the first 3 columns, the number in the 4th column (ONLY) should be deleted. The phone number format for the first 3 columns are (999) 999-9999. The phone number format for the 4th column is 999-999-9999.

Someone was nice enough to send me this macro quite awhile ago, (I don't remember who to thank them) but it doesn't seem to be working. It is not erasing the duplicates. Can anyone please advise?

Code:

Sub ClearDupesInC() 'cjamps
Dim LastC As Long, LastB As Long, i As Long, j As Long, n As Long

Application.ScreenUpdating = False
LastC = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
LastB = ActiveSheet.UsedRange.Rows.Count

For n = 3 To 4

For i = LastC To 2 Step -1       'if you have no header, go from LastC to 1
    If Left(Cells(i, n).Value, 1) = 1 Then
        Cells(i, n).Value = Right(Cells(i, n).Value, Len(Cells(i, n).Value) - 1)
    End If
    If Cells(i, n).Value <> "" And _
Application.WorksheetFunction.CountIf(Cells(LastC, n), Cells(i, n).Value) > 1 Then
        Cells(i, n).ClearContents
    End If
    If Cells(i, n).Value <> "" Then
    For j = LastB To 2 Step -1   'if you have no header, go from LastB to 1
        If (Right(Cells(i, n).Value, 8) = Right(Cells(j, n - 1).Value, 8) And _
        InStr(2, Left(Cells(j, n - 1).Value, 4), Left(Cells(i, n).Value, n))) _
        Or (Right(Cells(i, n).Value, 8) = Right(Cells(j, 1).Value, 8) And _
        InStr(2, Left(Cells(j, 1).Value, 4), Left(Cells(i, n).Value, n))) Then
            Cells(i, n).ClearContents
        End If
    Next j
    End If
Next i
Next n
Application.ScreenUpdating = True
End Sub

jolivanes · #2 12-10-2017, 07:48 PM

The Column to the right of your 4 columns with phone numbers needs to be free to use.
Change references as required. This code is for Column C to G.

Code:

Sub Try_This()
Dim i As Long
    With Range("F7:F" & Cells(Rows.Count, "F").End(xlUp).Row).Offset(, 1)
        .Formula = "= ""(""&LEFT(RC[-1],3)&"")""&"" ""&MID(RC[-1],5,3)&"" ""&MID(RC[-1],9,4)"
        .Value = .Value
    End With
    For i = 7 To Cells(Rows.Count, "F").End(xlUp).Row
        If Cells(i, 7) = Cells(i, 3) And Cells(i, 7) = Cells(i, 4) And Cells(i, 7) = Cells(i, 5) Then Cells(i, 6).Value = ""
    Next I
    Columns("G:G").ClearContents
End Sub

jolivanes · #3 12-10-2017, 08:29 PM

Another way with CountIf.
Note the references again.
I don't know which code will be faster on a larger range.

Code:

Sub Maybe_B()
Dim i As Long
Application.ScreenUpdating = False
    With Range("F7:F" & Cells(Rows.Count, "F").End(xlUp).Row).Offset(, 1)
        .Formula = "= ""(""&LEFT(RC[-1],3)&"")""&"" ""&MID(RC[-1],5,3)&"" ""&MID(RC[-1],9,4)"
        .Value = .Value
    End With
    For i = 7 To Cells(Rows.Count, "F").End(xlUp).Row
        If WorksheetFunction.CountIf(Range("C" & i & ":E" & i), Range("G" & i)) = 3 Then Cells(i, 6).ClearContents
    Next i
    Columns("G:G").ClearContents
Application.ScreenUpdating = True
End Sub

Pecoflyer · #4 12-11-2017, 12:39 AM

@cjamps
Hi
please post in the right forum next time. I will move it for you now
Thank you for helping us keep this forum orderly

cjamps · #5 12-12-2017, 02:03 AM

Hi jolivanes,

Thanx for posting. I tried the macros but couldn't get it to work. The first macro left rows of () in column G and the second macro didn't do anything. The duplicate phone numbers that have to be deleted are in column D.

The following code works for me even though it is slow with 2 issues:

1. I only want it to leave one instance of the phone number in column D if it doesn't exist. (I have to do it manually through excel.)
2. Sometimes when I paste the phone numbers into column D for some reason they have a 1 in front of the area code. (example format:1999-999-9999). Right now I have to delete the 1 manually for the macro to work.

Code:

Sub ClearDups()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim phone As Range
    Dim foundPhone As Range
    Dim sPhone As String
    Dim rng As Range
    For Each phone In Range("D2:D" & LastRow)
        sPhone = "(" & Left(phone, 3) & ") " & Mid(phone, 5, 8)
        Set foundPhone = Range("A2:C" & LastRow).Find(sPhone, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundPhone Is Nothing Then
            phone.ClearContents
        End If
    Next phone
   Application.ScreenUpdating = True
End Sub

jolivanes · #6 12-12-2017, 05:53 AM

Code:

Dim phone As Rang

Is that a typo (e missing)

cjamps · #7 12-12-2017, 06:50 AM

Whoops, you are right. I corrected it in the post.

Thanx

NoSparks · #8 12-12-2017, 10:11 AM

Another approach is to use in memory arrays.

jolivanes · #9 12-12-2017, 10:24 AM

My bad.
I misread the first post. I understood it to mean 3 columns on the same row.
My apologies.

jolivanes · #10 12-12-2017, 09:12 PM

Another long winded approach that might work.
Try on a copy of your original first.
Columns A, B and C have phone numbers to be compared to.
Column D has the phone numbers without bracketed area codes and a possible 1 in front
Columns E and F are empty and free to use.

Code:

Sub cjamps()
Dim i As Long, c As Range
Application.ScreenUpdating = False
    With Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
        .Offset(, 1).Formula = "=IF(LEN(RC[-1])=13,RIGHT(RC[-1],12),RC[-1])"
        .Offset(, 1).Value = .Offset(, 1).Value
        .Offset(, 2).Formula = "= ""(""&LEFT(RC[-1],3)&"")""&"" ""&MID(RC[-1],5,3)&"" ""&MID(RC[-1],9,4)"
        .Offset(, 2).Value = .Offset(, 2).Value
    End With
    For Each c In Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
        For i = 2 To Cells(Rows.Count, "F").End(xlUp).Row
            If WorksheetFunction.CountIf(Range(c.Offset(, -5).Address & ":" & c.Offset(, -3).Address), c.Value) <> 0 Then c.Offset(, -2).ClearContents: Exit For
        Next i
    Next c
    Columns("E:F").ClearContents
Application.ScreenUpdating = True
End Sub

NoSparks · #11 12-13-2017, 05:59 AM

Updated file for results to eliminate duplicates within column D .

Don't know what the desired output of the results should be.
Looking at this post of almost 2 years ago, I'd say column D isn't actually part of the A:C "table" so probably want what is indicated as Macro Results 2

cjamps · #12 12-13-2017, 06:58 AM

Quote:

Originally Posted by NoSparks

Updated file for results to eliminate duplicates within column D .

Don't know what the desired output of the results should be.
Looking at this post of almost 2 years ago, I'd say column D isn't actually part of the A:C "table" so probably want what is indicated as Macro Results 2

Yes. That is correct.

cjamps · #13 12-13-2017, 07:20 AM

jolivanes,

I tried running the macro but it didn't delete the duplicates.

jolivanes · #14 12-13-2017, 08:11 AM

For me it deleted the 1's where there were any and it deletes the dups.
I'll have a look later on.

NoSparks · #15 12-13-2017, 12:32 PM

Quote:

Originally Posted by cjamps

Yes. That is correct.

Is there an improvement in execution speed ?
Can this be considered a solution to what you've requested here or ???

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA: Delete duplicates in each row	bandaanders	Excel Programming	2	09-02-2015 08:15 AM
Excel vba to check to check if two columns are empty	subspace3	Excel Programming	5	07-09-2015 04:45 PM
Macro to keep first instance and remove duplicates in certain column	zhead	Excel	2	03-18-2015 10:16 AM
find and delete duplicates	rcVBA	Word VBA	4	05-15-2013 03:08 PM
Deleting Duplicates in Macro	jillapass	Excel Programming	1	01-11-2012 10:02 AM