word-track-revision

red.bas

Sub InsertRed()
    Dim rev As Revision
    Dim rng As Range
    Dim i As Integer
    Dim revCount As Integer

    ' 先停止追蹤修訂
    ActiveDocument.TrackRevisions = False

    ' 看追蹤修訂的數目
    revCount = ActiveDocument.Revisions.Count

    ' 從最後面開始一個一個輪流處理
    For i = revCount To 1 Step -1
        Set rev = ActiveDocument.Revisions(i)
        Set rng = rev.Range
        
        ' 如果是插入，改為紅色+底線
        If rev.Type = wdRevisionInsert Then
            rng.Font.Color = wdColorRed
            rng.Font.Underline = wdUnderlineSingle
        End If
        
        ' 如果是刪除，直接接受
        If rev.Type = wdRevisionDelete Then
            rev.Accept
        End If
    Next i
    
    ' 最後再次接受所有變更
    ActiveDocument.AcceptAllRevisions
End Sub

redblue.bas

Sub InsertRedDeleteBlue()
    Dim rev As Revision
    Dim rng As Range
    Dim newRng As Range
    Dim i As Integer
    Dim revCount As Integer
    ' 先停止追蹤修訂
    ActiveDocument.TrackRevisions = False
    ' 看追蹤修訂的數目
    revCount = ActiveDocument.Revisions.Count

    ' 從最後面開始一個一個輪流處理
    For i = revCount To 1 Step -1
        Set rev = ActiveDocument.Revisions(i)
        Set rng = rev.Range
        ' 如果是插入，改為紅色+底線
        If rev.Type = wdRevisionInsert Then
            rng.Font.Color = wdColorRed
            rng.Font.Underline = wdUnderlineSingle
        End If
        ' 如果是刪除，複製詞句放在後面
        If rev.Type = wdRevisionDelete Then
            Set newRng = rng.Duplicate
            newRng.Collapse Direction:=wdCollapseEnd
            newRng.Text = rng.Text
            ' 改為藍色+刪除線
            newRng.Font.Color = wdColorBlue
            newRng.Font.StrikeThrough = True
        End If
    Next i
    
    ' 最後再次接受所有變更
    ActiveDocument.AcceptAllRevisions
End Sub