Microsoft Office Forums - View Single Post - [Solved] Macro to check against Columns & Delete Duplicates

jolivanes · 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