Thanks Macropod but Word will, with track changes on, keep a record of both changes.
I did manage to solve the issue I was having. If anyone is interested here is the code:
Code:
Sub StrikethroughDeletions()
'Turn off Track Changes
ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
'Highlight revisions of type deletion
Number = ActiveDocument.Revisions.Count
For x = 1 To Number
Set myRev = ActiveDocument.Revisions(x).Range
This = ActiveDocument.Revisions(x).Type
If This = 2 Then
myRev.HighlightColorIndex = wdYellow
End If
Next x
' For all highlighted text, underline and strikethrough if also inserted
For Y = 1 To Number
Set myRev = ActiveDocument.Revisions(Y).Range
That = ActiveDocument.Revisions(Y).Type
If That = 1 Then
myRev.Select
If Selection.Range.HighlightColorIndex = wdYellow Then
Selection.Font.Underline = True
Selection.Font.StrikeThrough = True
End If
End If
Next Y
'This will then find and remove the deleted insertions
Selection.Find.ClearFormatting
With Selection.Find.Font
.Underline = wdUnderlineSingle
.StrikeThrough = True
.DoubleStrikeThrough = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'This will now delete all highlighting
Dim rngDoc As Range
Set rngDoc = ActiveDocument.Range(Start:=0, End:=0)
With rngDoc.Find
.ClearFormatting
.Highlight = True
With .Replacement
.ClearFormatting
.Highlight = False
End With
.Execute Replace:=wdReplaceAll, Forward:=True, FindText:="", _
ReplaceWith:="", Format:=True
End With
'Turn on track changes
ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
End Sub
Thanks all