Apply find/replace routine to entire document

I have a macro to ensure large numbers have commas in the correct locations.

My routine to insert commas works, but also includes dates, street #s, etc. (e.g., 15 January 2,022 and 1,234 Smith Street).

I am attempting to correct the street addresses, but am doing something wrong with my looping. It is only finding/fixing the first instance of a street number with a comma in it.

Note that the code snippet included several commented commands that I tried during troubleshooting.

'remove commas from street addresses
Set oRange = ActiveDocument.Range
With oRange.Find
    'Set the search conditions
    .ClearFormatting
    .Text = "(<[0-9]{1,2})(,)([0-9]{3})"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Execute
    
    'If .Found Then
    Do While .Found
        oRange.Select 'for debugging purposes
        If (InStr(1, "NorthEastWestSouth", Trim(oRange.Words(3).Next(wdWord, 1)), 0) <> 0 And Len(Trim(oRange.Words(3).Next(wdWord, 1))) > 1) Or _
            (InStr(1, "StreetAvenueRoadRdBoulevardBlvdPikeCircleHighwayHwyCourtCtLaneWayParkwayAlleyBypassEsplanadeFreewayJunctionRouteRteTraceTrailTurnpikeVille", _
                Trim(oRange.Words(3).Next(wdWord, 2)), 0) <> 0 And Len(Trim(oRange.Words(3).Next(wdWord, 2))) > 1) Or _
            (InStr(1, "StreetAvenueRoadRdBoulevardBlvdPikeCircleHighwayHwyCourtCtLaneWayParkwayAlleyBypassEsplanadeFreewayJunctionRouteRteTraceTrailTurnpikeVille", _
                Trim(oRange.Words(3).Next(wdWord, 3)), 0) <> 0 And Len(Trim(oRange.Words(3).Next(wdWord, 3))) > 1) Or _
            InStr(1, "N.E.W.S.", Trim(oRange.Words(3).Next(wdWord, 1) & Trim(oRange.Words(3).Next(wdWord, 2))), 0) <> 0 Then
               .Replacement.Text = "\1\3"
               .Execute Replace:=wdReplaceAll
               'oRange.Text = VBA.Replace(oRange.Text, ",", "")
        End If
        '.Execute
    'End If
    Loop 'continue finding
End With

Solution

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String, i As Long
StrFnd = "Alley|Avenue|Av|Boulevard|Blvd|Bypass|Circuit|Crct|Circle|Crcl|Court|Ct|Esplanade|Esp|Freeway|Fwy|" & _
    "Junction|Jnc|Highway|Hwy|Lane|Ln|Way|Parkway|Pike|Road|Rd|Street|St|Route|Rt|Trace|Trail|Turnpike|Ville"
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .Format = False
  .MatchWildcards = True
  'Process dates
  .Text = "([JFMASOND][anuryebchpilgstmov]{2,8} [12]),([0-9]{3})>"
  .Replacement.Text = "\1\2"
  .Execute Replace:=wdReplaceAll
  'Process addresses
  For i = 0 To UBound(Split(StrFnd, "|"))
    .Text = "([0-9]),([0-9]{3} <[A-Z][a-z]@> " & Split(StrFnd, "|")(i) & ")"
    .Execute Replace:=wdReplaceAll
    .Text = "([0-9]),([0-9]{3} [NSEW]. <[A-Z][a-z]@> " & Split(StrFnd, "|")(i) & ")"
    .Execute Replace:=wdReplaceAll
    .Text = "([0-9]),([0-9]{3} <[A-Za-z]@> <[A-Z][a-z]@> " & Split(StrFnd, "|")(i) & ")"
    .Execute Replace:=wdReplaceAll
    .Text = "([0-9]),([0-9]{3} [NSEW]. <[A-Za-z]@> <[A-Z][a-z]@> " & Split(StrFnd, "|")(i) & ")"
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

Not sure what you're trying to achieve with 'NorthEastWestSouth' and 'N.E.W.S.'