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

[gmaxey]

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

[h2whoa]

Greg, this is brilliant. Thank you so much! Really appreciate your help.

Sidenote: I love this community. Blown away by how clever and generous with advice people are here.