Counting the number of revisions by a specific author

[h2whoa]

Is it possible to count the number of revisions made by a specific author? That is not my ultimate end goal, but would be extremely useful for something I'm working.

I know that you can count revisions in a document, but wonder if you can be more selective. Basically, I'm clumsily putting something together that will let you go through insertion or deletion and change the apparent author name (I know you can't do it directly, so it's basically a case of the code rejecting the change but then reapplying them so that the current username becomes the apparent author).

I've got something that works, but it goes through every insertion and deletion, regardless of author. I want to make it skip revisions made by authors who are not of interest. However, in order to stop the code going into an endless loop, I need to get it to exit if the document does not contain any more insertions or deletions made by a specified author.

The key area of the code that needs this ability to break out of the loop is at the SelRN2 region, where there is an IF test to skip a revision if the author is not the one specified previously.

Public Sub Track_Rev_Nm_Chng()
    Dim nCount As Long
    Dim sNext, sUsername, sUserInit, sOrigname, sOriInit, selAuth, AuthChng As String
    Dim ReturnValue As Integer
    
    sOrigname = Application.UserName
    sOriInit = Application.UserInitials
    nCount = ActiveDocument.Revisions.Count
    
    If nCount = 0 Then
        MsgBox "There are no tracked changes.", vbOKOnly, Title
        GoTo Ending
    Else
        If MsgBox("Change user name first?", vbYesNo) = vbYes Then
            sUsername = InputBox("New user name", _
                        "Insert full name")
                        If sUsername = "" Then End
    
            sUserInit = InputBox("New user initials", _
                        "Insert initials")


            Application.UserName = sUsername
            Application.UserInitials = sUserInit
            GoTo Revs
        Else
            sUsername = sOrigname
        End If


        selAuth = MsgBox("Only select revisions from specific person?", vbYesNo)
        If selAuth = vbNo Then
Revs:
            If MsgBox("Next track change?", vbYesNo) = vbYes Then
                Selection.NextRevision (True)
                    sNext = MsgBox("Change name?", vbYesNo)
                    If sNext = vbYes Then
                        With Selection
                        If .Range.Revisions(1).Type = wdRevisionInsert Then
                            Selection.Copy
                            Selection.Range.Revisions.RejectAll
                            Selection.PasteAndFormat (wdFormatOriginalFormatting)
                            GoTo Revs
                        Else
                            If .Range.Revisions(1).Type = wdRevisionDelete Then
                                Selection.Range.Revisions.RejectAll
                                Selection.Cut
                                GoTo Revs
                            End If
                        End If
                        End With
                    Else
                        If sNext = vbNo Then
                            GoTo Revs
                        End If
                    End If
            Else
                GoTo Revert
            End If
        Else
            If selAuth = vbYes Then
SelR:
                AuthChng = InputBox("Reviewer name to replace")
                    If AuthChng = "" Then GoTo Ending


SelRN1:
                If MsgBox("Next track change?", vbYesNo) = vbYes Then
SelRN2:
                    Selection.NextRevision (True)
                        If Selection.Range.Revisions(1).Author = AuthChng Then
                            sNext = MsgBox("Change name?", vbYesNo)
                            If sNext = vbYes Then
                                With Selection
                                If .Range.Revisions(1).Type = wdRevisionInsert Then
                                    Selection.Copy
                                    Selection.Range.Revisions.RejectAll
                                    Selection.PasteAndFormat (wdFormatOriginalFormatting)
                                    GoTo SelRN1
                                Else
                                    If .Range.Revisions(1).Type = wdRevisionDelete Then
                                        Selection.Range.Revisions.RejectAll
                                        Selection.Cut
                                        GoTo SelRN1
                                    End If
                                End If
                                End With
                            Else
                                If sNext = vbNo Then
                                    GoTo SelRN1
                                End If
                            End If
                        Else
                            GoTo SelRN2
                        End If
                Else
                    GoTo Revert
                End If
            End If
        End If
Revert:
        If sUsername = sOrigname Then
            GoTo Ending
        Else
            If MsgBox("Revert user name?", vbYesNo) = vbYes Then
                Application.UserName = sOrigname
                Application.UserInitials = sOriInit
                GoTo Ending
            Else
                GoTo Ending
            End If
        End If
    End If
    
Ending:
    ReturnValue = MsgBox("Process ended", vbOKOnly, "Revision author alterations")
    End Sub