Convert underline/strikethrough to Track Changes

[MarkAGJones]

Dear Friends,

I have found several helpful snippets of code on here to convert MSWord Track Change revisions to underline/strikethrough revisions as character formatting.

I have the reverse problem, however: I have a document where insertions are shown as underline, and deletions are shown as strikethrough with character formatting, and I want to work with it as a change-tracked document, for example with with my revisions on top, or to accept/reject certain revisions. So, I need to transform the character formatting underline to Track Change insertion, and the character formatting strikethrough to Track Change deletion.

Trying to do this via Find/Replace is having me tearing my hair out.

Would anyone have a clue as to how to do this with a bit of VBA?

All the best,

Mark

 

[mintjulep]

Start by turning on macro recorder.

Then do what you are doing.

 

[strongm]

Handling deletions is relatively easy, assuming I've understood your problem properly. Insertions are harder ...

[blue]    Dim OldTrack As Boolean
    
    OldTrack = ActiveDocument.TrackRevisions
    
    If Not OldTrack Then ActiveDocument.TrackRevisions = True

    With Selection.Find
        .ClearFormatting
        .Font.StrikeThrough = True
        .Text = ""
        .Replacement.Text = ""
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveDocument.TrackRevisions = OldTrack[/blue]

 

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim StrTxt As String
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Format = True
      .Font.StrikeThrough = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      .End = .Words.Last.End
      StrTxt = .Text
      ActiveDocument.TrackRevisions = False
      .Text = StrTxt
      ActiveDocument.TrackRevisions = True
      .Delete
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Format = True
      .Font.Underline = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      If .Words.First.Previous = " " Then
        .Start = .Start - 1
      Else
        .End = .Words.Last.End
      End If
      StrTxt = .Text
      ActiveDocument.TrackRevisions = False
      .Text = vbNullString
      ActiveDocument.TrackRevisions = True
      .Text = StrTxt
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  .TrackRevisions = False
End With
Application.ScreenUpdating = True
End Sub

Cheers
Paul Edstein
[MS MVP - Word]