Написал макрос генерирующий таблицу изменений — протокол разногласий в режиме исправления. В принципе хорошо работает, но есть одно но — не правильно дает индекс измененных абзацев с автоматической их нумерацией.
Вернее либо правильно дает индекс удаляемого абзаца и неправильно индекс вставляемого абзаца, либо наоборот.
Причем зависит это от перемены мест блоков 1 и 2
Какие могут быть советы, или это неустранимый глюк ворда?

Function RemoveCr(s As String) As String
    While Right$(s, 1) = Constants.vbCr
    s = Left$(s, Len(s) - 1)
    Wend
    RemoveCr = s
    Exit Function
End Function
Function IsExsist(collect As Collection, sKey As String) As Boolean
    On Error GoTo Er_
    
    Dim vItem As Variant
    vItem = collect(sKey)
        
    IsExsist = True
    Exit Function
    
Er_:
    IsExsist = False
    Exit Function
End Function

Sub ПротоколРазногласий()
'
'
With ActiveWindow.View
    .ShowRevisionsAndComments = False
End With

'Блок 1
With ActiveWindow.View
    .RevisionsView = wdRevisionsViewFinal
End With
'Конец Блока 1

Set rev = ActiveDocument.Revisions
Dim parrange As New Collection
Dim keys As New Collection
For Each i In rev
    If IsExsist(parrange, Str(i.Range.Paragraphs(1).Range.Start)) = False Then
      parrange.Add Item:=i.Range.Paragraphs(1).Range, Key:=Str(i.Range.Paragraphs(1).Range.Start)
      keys.Add Item:=Str(i.Range.Paragraphs(1).Range.Start), Key:=Str(i.Range.Paragraphs(1).Range.Start)
      End If
Next i

'Блок 2
With ActiveWindow.View
    .RevisionsView = wdRevisionsViewOriginal
End With
'Конец Блока 2


Set rev = ActiveDocument.Revisions
For Each i In rev
    If IsExsist(parrange, Str(i.Range.Paragraphs(1).Range.Start)) = False Then
      parrange.Add Item:=i.Range.Paragraphs(1).Range, Key:=Str(i.Range.Paragraphs(1).Range.Start)
      keys.Add Item:=Str(i.Range.Paragraphs(1).Range.Start), Key:=Str(i.Range.Paragraphs(1).Range.Start)
      End If
Next i


Dim Now As New Collection
Dim rNow As New Collection

Dim Was As New Collection
Dim lNow As New Collection
Dim lWas As New Collection

  
With ActiveWindow.View
    .RevisionsView = wdRevisionsViewOriginal
End With

For Each i In keys
    Was.Add Item:=parrange(i).Text, Key:=i
    lWas.Add Item:=parrange(i).ListFormat.ListString, Key:=i
Next i

With ActiveWindow.View
    .RevisionsView = wdRevisionsViewFinal
End With
  
For Each i In keys
    Now.Add Item:=parrange(i).Text, Key:=i
    lNow.Add Item:=parrange(i).ListFormat.ListString, Key:=i
    rNow.Add Item:=parrange(i), Key:=i
    
Next i

Dim temp As New Collection

'ActiveDocument.Revisions.AcceptAll
ActiveDocument.TrackRevisions = False

    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
        2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = True
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = True
    End With
    Selection.TypeText Text:="Было"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="Стало"
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
  
    Selection.InsertRows keys.Count
For Each i In keys
    If RemoveCr(Now(i)) = RemoveCr(Was(i)) Then GoTo n
    With ActiveWindow.View
        .RevisionsView = wdRevisionsViewOriginal
    End With
    If RemoveCr(Was(i)) = "" Then Selection.TypeText "Добавлено" Else: Selection.TypeText lWas(i) + " " + RemoveCr(Was(i))
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    With ActiveWindow.View
        .RevisionsView = wdRevisionsViewFinal
    End With
    If RemoveCr(Now(i)) = "" Then
    Selection.TypeText "Удалено;"
    Else
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, SubAddress:=rNow(i), TextToDisplay:=lNow(i) + " " + RemoveCr(Now(i))
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    
n:
Next i
    With ActiveWindow.View
        .RevisionsView = wdRevisionsViewFinal
    End With

End Sub