Sub Demo()
Application.ScreenUpdating = False
Dim TrkStatus As Boolean, StrTxt As String, Rng As Range
With ActiveDocument
  TrkStatus = .TrackRevisions
  .TrackRevisions = True
  Set Rng = .Range(0, 0)
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
    End With
 
    'Fix SSNs
    .Start = Rng.Start
    With .Find
      .Text = "SSN[: ]{1,2}[0-9]{9}>"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .Start = .End - 7
      .End = .End - 3
      .InsertAfter "-"
      .InsertBefore "-"
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
 
    'Fix SSIDs
    .Start = Rng.Start
    With .Find
      .Text = "SSID[: ]{1,2}[0-9]{10}>"
      .Execute
    End With
    Do While .Find.Found
      .Collapse wdCollapseEnd
      .Text = " (Status: Approved)"
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
 
    'Fix Date Ranges
    .Start = Rng.Start
    With .Find
      .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
      .Execute
    End With
    Do While .Find.Found
      Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
        Case "between": StrTxt = " and "
        Case "from": StrTxt = " to "
        Case "of": StrTxt = " through "
      End Select
      .Start = .Start + InStr(.Text, "-") - 1
      .End = .Start + 1
      .Duplicate.Text = StrTxt
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
 
  End With
  .TrackRevisions = TrkStatus
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub