A different approach:
Public Sub RevisionAuthorChange()
Dim lngRevCount As Long
Dim strAppAuthorInitials As String, strAppAuthorName As String
Dim strRevAuthorName As String, strRevAuthorInitials As String
Dim strRevAuthorToReview As String
Dim bAll As Boolean
Dim colRevs
Dim oRev As Revision
Dim lngCount As Long
Dim lngView As Long
lngView = ActiveDocument.ActiveWindow.View
bAll = True
Set colRevs = fcnRevs
lngRevCount = colRevs.Count
If lngRevCount = 0 Then
MsgBox "There are no tracked insertions or deletions.", vbOKOnly, "Title"
Exit Sub
End If
strAppAuthorName = Application.UserName
strAppAuthorInitials = Application.UserInitials
If MsgBox("Current author is " & strAppAuthorName & ". Do you want to change the revision author?", vbYesNo) = vbYes Then
strRevAuthorName = InputBox("New author name", "Insert full name")
strRevAuthorInitials = InputBox("New auhtor initials", "Insert initials")
Application.UserName = strRevAuthorName
Application.UserInitials = strRevAuthorInitials
Else
strRevAuthorName = strAppAuthorName
End If
If MsgBox("Do you want to review revisions by all authors?", vbYesNo, "REVIEW ALL") = vbNo Then
strRevAuthorInitials = InputBox("Reveiw revisions by:", "Define Author")
bAll = False
End If
For Each oRev In colRevs
lngCount = lngCount + 1
If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
If oRev.Author = strRevAuthorInitials Or bAll Then
oRev.Range.Select
If MsgBox("Do you want to change the author of this revision to " & Application.UserName & "?", vbYesNo, "CHANGE REVISION AUTHOR") = vbYes Then
Select Case oRev.Type
Case wdRevisionInsert
Selection.Copy
Selection.Range.Revisions.RejectAll
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Case wdRevisionDelete
Selection.Range.Revisions.RejectAll
Selection.Cut
End Select
End If
End If
End If
If lngCount = lngRevCount Then Exit For
Next oRev
If Not strRevAuthorName = strAppAuthorName Then
If MsgBox("Restore original Application User Name?", vbYesNo) = vbYes Then
Application.UserName = strAppAuthorName
Application.UserInitials = strAppAuthorInitials
End If
End If
lbl_Exit:
ActiveDocument.ActiveWindow.View = lngView
MsgBox "Process ended", vbOKOnly, "Revision author alterations"
End Sub
Function fcnRevs() As Collection
Dim rngStory As Word.Range
Dim lngIndex As Long
Dim oShp As Shape
Dim oRev As Revision
lngIndex = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
Dim oColl As New Collection
'Iterate through all linked stories
Do
On Error Resume Next
For Each oRev In rngStory.Revisions
If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
lngIndex = lngIndex + 1
oColl.Add oRev, CStr(lngIndex)
End If
Next oRev
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
oColl.Add oRev, CStr(lngIndex + 1)
End If
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
Set fcnRevs = oColl
End Function