VBA to replace first four digits of a phone number using regex

[jscranton]

Can anyone help me amend this snippet to instead of adding periods to break up a phone number to replacing the first four digits with an "x"?

Thanks,

J

Sub SymbolsInPhN()
Dim rRng As Range, rCell As Range
 
Set rRng = Range("A2", Range("A" & Rows.Count).End(xlUp))
 
With CreateObject("vbscript.regexp")
    .Pattern = "(\d{3})(\d{3})(\d{4})"
    .Global = True
    
    For Each rCell In rRng
        If rCell.Value <> "" Then _
            rCell.Value = .Replace(rCell.Value, "$1.$2.$3")
    Next rCell
End With
End Sub

 

[Rick Rothstein]

It is not RegExp, but I think this does what you want...

[table="width: 500"]
[tr]
	[td]Sub SymbolsInPhN()
  Dim Addr As String
  Addr = "A2:A" & Cells(Rows.Count, "A").End(xlUp).Row
  Range(Addr) = Evaluate(Replace("IF(@="""","""",""x""&MID(@,5,6))", "@", Addr))
End Sub[/td]
[/tr]
[/table]

 

[jscranton]

Thanks Rick. That works to a degree. The issue I am trying to solve is a little more complex in that sometimes the entire value is a phone number but other times the phone number is in a string so I think I need a regex pattern.

 

[Rick Rothstein]

Thanks Rick. That works to a degree. The issue I am trying to solve is a little more complex in that sometimes the entire value is a phone number but other times the phone number is in a string so I think I need a regex pattern.

Still not a RegExp solution, but how about this macro...

Sub SymbolsInPhN()
  Dim X As Long, R As Long, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  For R = 1 To UBound(Data)
    For X = 1 To Len(Data(R, 1))
      If Mid(Data(R, 1), X) Like "##########*" Then
        Data(R, 1) = "x" & Mid(Data(R, 1), X + 4, 6)
        Exit For
      End If
    Next
  Next
  Range("[B][COLOR="#FF0000"]A2[/COLOR][/B]").Resize(UBound(Data)) = Data
End Sub

NOTE: I put the output back in the cells where the data was originally located, but you can output the data elsewhere by changing the red highlighted cell address to the address of the first cell you want the output to go to (for example, changing it to B2 will place the output in Column B starting on Row 2).

 

[LockeGarmin]

You're macro will work, you just need to alter the pattern and replace value like the following:

Sub SymbolsInPhN()
Dim rRng As Range, rCell As Range
 
Set rRng = Range("A2", Range("A" & Rows.Count).End(xlUp))
 
With CreateObject("vbscript.regexp")
    .Pattern = "[COLOR=#ff0000]\d{4}(?=\d{6})[/COLOR]"
    .Global = True
    
    For Each rCell In rRng
        If rCell.Value <> "" Then _
            rCell.Value = .Replace(rCell.Value, "[COLOR=#ff0000]x[/COLOR]")
    Next rCell
End With
End Sub

I did optimize this macro a little bit by making further changes if you are interested:

Sub SymbolsInPhN()
Dim rRng As Range, [COLOR=#ff0000]Data As Variant, x As Long[/COLOR]

Set rRng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR=#ff0000]Data = rRng.Value2[/COLOR]

With CreateObject("vbscript.regexp")
    .Pattern = "\d{4}(?=\d{6})"
    .Global = True
    
    For x = 1 To rRng.Rows.Count
        If [COLOR=#ff0000].Test(Data(x, 1))[/COLOR] Then _
            Data(x, 1) = .Replace(Data(x, 1), "x")
    Next x
End With

[COLOR=#ff0000]rRng.Value2 = Data[/COLOR]

End Sub

 

[jscranton]

Thanks. Just getting back to this.

Your code worked great. I may a minor edit as we want to anonymize the first four digits.

I had a related problem that I tried to solve (and partially) did but am wondering how the .Replace functions works with my new pattern which is intended to find this version of a phone number 123 456-7891:

With CreateObject("vbscript.regexp")
    .Pattern = "\d{3} (?=\d{3}-\d{4})"
    .Global = True
    
    For x = 1 To redactionRange.Rows.Count
        
        If .Test(Data(x, 1)) Then _


            Data(x, 1) = .Replace(Data(x, 1), "xxx x")
            Debug.Print Data(x, 1)
        End If


    Next x
End With

I am trying again to replace the first four numeric characters. Any suggestions?

 

[jscranton]

Okay. i Figured out the problem was in my pattern. This is working.

With CreateObject("vbscript.regexp")
    .Pattern = "\d{3}\s\d{1}(?=\d{2}\-\d{4})"
    .Global = True
    
    For x = 1 To redactionRange.Rows.Count
        
        If .Test(Data(x, 1)) Then _
            Data(x, 1) = .Replace(Data(x, 1), "xxx x")
        End If


    Next x
End With

 

[LockeGarmin]

You're welcome! Nice job with figuring out your pattern. Below is pattern/replace that demonstrates how to use the replace functionality with similar patterns but keeping the variations. Hope that can be helpful to you in the future.

With CreateObject("vbscript.regexp")
    .Pattern = [COLOR=#ff0000]"\d{3}([\s-]?)\d(?=\d{2}[\s-]?\d{4})"[/COLOR]
    .Global = True
    
    For x = 1 To redactionRange.Rows.Count
        
        If .Test(Data(x, 1)) Then _

            Data(x, 1) = .Replace(Data(x, 1), [COLOR=#ff0000]"xxx$1x"[/COLOR])
            Debug.Print Data(x, 1)
        End If

    Next x
End With