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