Apply find/replace routine to entire document - vba

Question

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

Answer 1

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.'