Macro to check against Columns & Delete Duplicates

jolivanes · #16 12-13-2017, 02:16 PM

Don't know the layout of your sheet but attached seems to work.
Might be slow on a very large range though.

cjamps · #17 12-13-2017, 09:04 PM

Yes you are right. It does work. I can't understand why it doesn't work on my spreadsheet. I replaced my columns with yours using your spreadsheet, ran the macro and nothing happened. I would post the columns but the phone numbers are confidential.

jolivanes · #18 12-13-2017, 09:21 PM

Any leading or trailing spaces?

NoSparks · #19 12-14-2017, 07:38 AM

@ cjamps
does this array approach work with the data you can't post or am I wasting my time trying to help ?

Code:

Function onlynumbers(ByVal ref As String)
' remove all but digits from string
Dim rx As Object
Set rx = CreateObject("VBScript.RegExp")
With rx
    .Pattern = "\D"
    .Global = True
    onlynumbers = .Replace(ref, "")
End With
End Function


Sub cjamps_Delete_Duplicates()

    Dim lr As Long, i As Long, j As Long, k As Long, x As Long
    Dim ws As Worksheet, ray1, ray2
    Dim dic As Object
    
Set ws = ThisWorkbook.Sheets("Sheet1")
Set dic = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

With ws
    lr = .Columns("A:C").Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    ray1 = .Range("A2:C" & lr).Value
        For i = 1 To UBound(ray1, 1)
            For j = 1 To UBound(ray1, 2)
                ray1(i, j) = onlynumbers(ray1(i, j))
                'populate dictionary
                If ray1(i, j) <> "" Then dic(ray1(i, j)) = True
            Next j
        Next i
        
    ray2 = .Range("D2", ws.Range("D" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(ray2, 1)
            ray2(i, 1) = onlynumbers(ray2(i, 1))
        Next i
    
    'check dictionary for ray2 elements
    'MsgBox LBound(ray2) & vbLf & UBound(ray2)
    For k = 1 To UBound(ray2, 1)
        If dic.exists(Right(ray2(k, 1), 10)) Then
            ray2(k, 1) = ""
        Else
            dic(Right(ray2(k, 1), 10)) = True
            ray2(k, 1) = Format(ray2(k, 1), "000-000-0000")
        End If
    Next k
    
    'clear original col D
    .UsedRange.Columns("D").Offset(1).ClearContents
    'write ray2 to column D, omitting blanks
    x = 2
    For i = 1 To UBound(ray2, 1)
        If ray2(i, 1) <> "" Then
            .Cells(x, 4) = ray2(i, 1)
            x = x + 1
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

cjamps · #20 12-14-2017, 08:16 AM

I think we have to find out why these macros are not working on my code but they are working on the sample.

I don't think that there are leading spaces but how could I find out?

Let's take Jolivanes code for example. I am attaching a sample of initiating the debug.
Using the Debug, expression c becomes rangerange and expression i goes up to 35 and then goes to the next i.

Now what is happening is very strange. Columns E & F are filling up with the same numbers as in column D. [Column E without () such as 999-999-9999 and column F with () such as (999)999-9999] My column D contains 22 cells of numbers. Cells 23 to 33 fill up with (). I did not go through the whole debug but if I would run the macro without the debug, nothing would be changed.

jolivanes · #21 12-14-2017, 08:49 AM

Attach your workbook. Change numbers but not the formatting etc.
In an empty column to the right in the first cell, put "=Len(A1)"
Drag formula 4 columns to the right and however many rows you have in Columns A to D
All numbers should correspond to the amount you need it to be. 14 For Columns A, B and C and 12 For Column D

jolivanes · #22 12-14-2017, 09:35 AM

If you do have leading or trailing spaces, this should take care of it as part of the code.

Code:

Sub cjamps_B()
Dim i As Long, c As Range, rng As Range
Application.ScreenUpdating = False
    Set rng = Range("A2:D" & Cells(Rows.Count, "D").End(xlUp).Row)    '<----- Range with ALL phone numbers
    rng.Value = Application.Trim(rng)    '<---- Trims a range instead of looping cells
    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
    ActiveSheet.UsedRange.Columns("E:F").Offset(1).ClearContents
Application.ScreenUpdating = True
End Sub

cjamps · #23 12-15-2017, 06:02 AM

Attached please find the uploaded file. I hope I replaced all the phone numbers to protect the members. I know that there are at least 2 duplicates in column D. Please tell me if the macro works for you.

Thanx

NoSparks · #24 12-15-2017, 10:49 AM

The array macro leaves only these of column D
and only one of each

999-999-5977
999-999-3367
999-999-0575
999-999-9429
999-999-2672
999-999-6295

is this correct ?

jolivanes · #25 12-15-2017, 07:57 PM

I think I understand it different now.
If you have doubles, triples or more in Column D, you want to delete the double and triple or more if you have more but leave one. Is that the idea?

jolivanes · #26 12-15-2017, 08:10 PM

In your attached workbook in sheet "Tiferes Miriam Contacts" this leaves only unique values in Column D

Code:

Sub Delete_Doubles_Miriam_Contacts_Sheet()
Dim i As Long, c As Range, rng As Range, lr As Long
lr = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
Application.ScreenUpdating = False
    Set rng = Range("A2:D" & lr)
    rng.Value = Application.Trim(rng)
    For Each c In Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row).SpecialCells(2)
        c.Offset(, 1).Formula = "=IF(LEN(RC[-1])=13,RIGHT(RC[-1],12),RC[-1])"
        c.Offset(, 1).Value = c.Offset(, 1).Value
        c.Offset(, 2).Formula = "= ""(""&LEFT(RC[-1],3)&"")""&"" ""&MID(RC[-1],5,3)&"" ""&MID(RC[-1],9,4)"
        c.Offset(, 2).Value = c.Offset(, 2).Value
    Next c
For i = 3 To Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(i, 4) <> "" And WorksheetFunction.CountIf(Range("$F$" & i & ":$F" & Cells(Rows.Count, 4).End(xlUp).Row), Cells(i, 6)) > 1 Then Cells(i, 4).ClearContents
Next i
    ActiveSheet.UsedRange.Columns("E:F").Offset(1).ClearContents
Application.ScreenUpdating = True
End Sub

cjamps · #27 12-17-2017, 11:33 PM

NoSparks,

THANX TONS!!! That's it. You got it. Sorry this took so long, I guess I really did not explain myself properly. I appreciate all your time and effort.

Jolivines,

Yes. But also if it exists in column a,b or c it should be deleted as well. [ONLY the phone number in column D should be deleted, the first 3 rows must be untouched.] I ran your macro on the attached file and highlighted the duplicates that the macro should remove because they exist in the previous columns.

NoSparks · #28 12-18-2017, 06:38 AM

You're welcome, glade I could help. Please log in and use the Forum Tools drop down to mark the thread as Solved, thanks.

Also, read this in case you should be asking for assistance again.
It's a requirement of the rules at virtually all the forums including this one and both MrE and EF.

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