Option Explicit
Sub FormatNumbers()
    Dim lngdb As Long
    If Selection.Type = wdSelectionIP Then
        ActiveDocument.Range(0, 0).Select
        lngdb = wdFindContinue
    Else
        lngdb = wdFindStop
    End If
    With Selection.Find
        .ClearFormatting
        .Text = "[0-9]{4,}"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = lngdb
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        Do While .Execute
            Selection.Text = Format$(Selection.Text, "#,##0")
            If lngdb = wdFindContinue Then
                Selection.Collapse wdCollapseEnd
            Else
                Exit Sub
            End If
        Loop
    End With
End Sub