Sub TrackChanges()
Application.ScreenUpdating = False
Dim bTrk As Boolean
With ActiveDocument
  bTrk = .TrackRevisions
  .TrackRevisions = False
  With .Range
    With .Find
      .ClearFormatting
      .Format = False
      .Forward = False
      .Wrap = wdFindStop
      .Text = ""
      .Replacement.Text = ""
      .Font.Underline = True
    End With
    Do While .Find.Execute
      .Font.Underline = False
      .Cut
      ActiveDocument.TrackRevisions = True
      .Paste
      ActiveDocument.TrackRevisions = False
      .Collapse wdCollapseStart
    Loop
  End With
  With .Range
    With .Find
      .ClearFormatting
      .Forward = False
      .Wrap = wdFindStop
      .Font.StrikeThrough = True
    End With
    Do While .Find.Execute
      .Font.StrikeThrough = False
      ActiveDocument.TrackRevisions = True
      .Delete
      ActiveDocument.TrackRevisions = False
      .Collapse wdCollapseStart
    Loop
  End With
  .TrackRevisions = bTrk
End With
Application.ScreenUpdating = True
End Sub