Excel macro to replace part of string

Question

I'm having trouble replacing part of a string in a range of data that includes comments.

Where ID numbers appears, I need to replace the middle of the ID numbers with Xs (e.g. 423456789 to become 423xxx789). The IDs only ever start with 4 or 5 and any other number should be ignored as it may be necessary for other purposes.

Sadly, because these are comments the data is inconsistently formatted which adds a level of complexity.

Representative data would look like the following:

523 123 123
523123123
ID 545 345 345 is Mr. Jones
Primary ID 456456456 for Mrs. Brown
Mr. Smith's Id is 567567567

I need the code to only replace the middle 3 digits of the ID number and leave the rest of the cell intact so that

ID 545 345 345 is Mr. Jones 
Primary ID 456456456 for Mrs. Brown

Becomes (with or without spaces around the Xs)

ID 545 xxx 345 is Mr. Jones 
Primary ID 456xxx456 for Mrs. Brown

The regex I have is finding the lines with IDs successfully, and works nicely for the cells with no other text. Sadly, for the other cells it will not replace just the 3 digits that need replacing and makes a mess of data the cell. My code below works for the first two cells above, then doesn't work so well for the remainder. Please help.

Sub FixIds()

Dim regEx As New RegExp
    Dim strPattern As String: strPattern = "([4][0-9]{2})([^a-zA-Z0-9_]?[0-9]{3})([^a-zA-Z0-9_]?[0-9]{3})|([5][0-9]{2})([^a-zA-Z0-9_]?[0-9]{3})([^a-zA-Z0-9_]?[0-9]{3})"
Dim strReplace As String: strReplace = ""
Dim strInput As String
Dim Myrange As Range
Dim NewPAN As String
Dim Aproblem As String
Dim Masked As Long
Dim Problems As Long
Dim Total As Long

'Set RegEx config/settings/properties
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern ' sets the regex pattern to match the pattern above
    End With

Set Myrange = Selection

MsgBox ("The macro will now start masking IDs identified in the selected cells only.")
' Start masking the IDs
    For Each cell In Myrange
        Total = Total + 1
        ' Check that the cell is long enough to possibly be an ID and isn't already masked
        Do While Len(cell.Value) > 8 And Mid(cell.Value, 5, 1) <> "x" And cell.Value <> Aproblem
            If strPattern <> "" Then

                cell.NumberFormat = "@"
                strInput = cell.Value
                NewPAN = Left(cell.Value, 3) & "xxx" & Right(cell.Value, 3)
                strReplace = NewPAN

' Depending on the data, fix it
                If regEx.Test(strInput) Then
                    cell.Value = NewPAN
                    Masked = Masked + 1
                Else
                    ' Adds the cell value to a variable to allow the macro to move past the cell
                    Aproblem = cell.Value
                    Problems = Problems + 1
                    ' Once the macro is trusted not to loop forever, the message box can be removed
                    ' MsgBox ("Problem. Regex fail? Bad data = " & Aproblem)
                End If
            End If
        Loop
    Next cell

' All done
MsgBox ("IDs are now masked" & vbCr & vbCr & "Total cells highlighted (including blanks) = " & Total & vbCr & "Cells masked = " & Masked & vbCr & "Problem cells = " & Problems)
End Sub

Answer 1

I removed the Do... While loop and changed the logics in your For Each cell In Myrange code so as to process matches one by one and create a specific replacements if we have non-empty value in the first or fourth capturing group (we can choose which values to choose for replacement then).

For Each cell In Myrange
    Total = Total + 1
    ' Check that the cell is long enough to possibly be an ID and isn't already masked

        If strPattern <> "" Then

            cell.NumberFormat = "@"
            strInput = cell.Value

            ' Depending on the data, fix it
            If regEx.test(strInput) Then
              Set rMatch = regEx.Execute(strInput)
              For k = 0 To rMatch.Count - 1
                 toReplace = rMatch(k).Value
                 If Len(rMatch(k).SubMatches(0)) > 0 Then ' First pattern worked
                   strReplace = rMatch(k).SubMatches(0) & "xxx" & Trim(rMatch(k).SubMatches(2))
                 Else ' Second alternative is in place
                   strReplace = rMatch(k).SubMatches(3) & "xxx" & Trim(rMatch(k).SubMatches(5))
                 End If
                 cell.Value = Replace(strInput, toReplace, strReplace)
                 Masked = Masked + 1
               Next k
            Else
                ' Adds the cell value to a variable to allow the macro to move past the cell
                Aproblem = cell.Value
                Problems = Problems + 1
                ' Once the macro is trusted not to loop forever, the message box can be removed
                ' MsgBox ("Problem. Regex fail? Bad data = " & Aproblem)
            End If
        End If

Next cell

Here is the result: