So, many of the dumb questions that I've been asking recently are because I've been working on trying to update the famous comment and revision trackers by Lene Fredborg, DocTools. I claim no particular credit for any of the code below. Most of it is just modified from the Lene Fredborg original. I'm also indebted to macropod, gmayor and John Wilson for their extreme helpfulness while I've been trying to get to grips with VBA. All of this is to say: I am not attempting to steal any credit for other's hard work.
However, I have hit a final brick wall that I am wasting a lot of time trying to get past and so I'm crying out for one last bit of help on this.
The modified code is now a combined revision and comment grid maker, with options to do one or the other (or both). It also gives you the option to exclude comments and revisions from specific authors.
But I'm having a problem that I can't seem to get around at the last part. For some reason, I can no longer populate the final table with the details of the tracked insertions and deletions. It is still counting them, and creating the right number of rows, but it is not populating the cells with the information for each revision. Obviously that's a problem!
When you look at the code, you may wonder why I've gone for cycling through revisions using "For integer = 1 to revision counts" loops, instead of using the neater "For Each Revision in ActiveDocument.Revisions". I've found that using the neater method creates a runtime error if there are overlapping revisions, in which VBA seems to fall over in trying to define the Revision.Type.
So I used the messier 'For 1 to...' method to get around this. I know this seems to work in the other instances of the code, as it is producing an accurate list of revision authors and number of insertions and deletions. But it seems to be failing at the last bit of the macro (in the "Tracks:" section), so I end up with a blank table. If anyone can work out why it is doing this, and how I can get around it, while still avoiding the runtime error that comes from "For Each Revision...", you'll have made my week. Maybe my year.
Public Sub Rev_and_Comm_Tracker() Dim oDoc, oNewDoc As Document Dim oTable As Table Dim oRange As Range Dim nCount, n, i, numRows, rCount, rCount2, rTb, cTb, blRows, cax, rax, b, c, d, j, k, w, x, y, z, cmCounter, revCounter, sCmtTally, sRevTally As Long Dim noCol As Integer Dim Title, strText, selType, selType2, finSel, exAuth, exRev, exAuthNum, exRevNum, Auth2ex1, Auth2ex2, Auth2ex3, Auth2ex4, Auth2ex5 As String Dim Rev2ex1, Rev2ex2, Rev2ex3, Rev2ex4, Rev2ex5, initCSum, initRSum As String Dim sCmAuTxt1, sCmAuTxt2, sCmAuTxt3, sCmAuTxt4, sRvAuTxt1, sRvAuTxt2, sRvAuTxt3, sRvAuTxt4, stCmtAuth, stRvAuth, sAllCmtAus, sAllRvAus, CmtMax, RvMax As String Dim CmtOne, RvOne, CmtMaxOp, RvMaxOp, CmtAuNum, RvAuNum, AuNumRet, RevNumRet, CmntCnter, RevCnter, CmntSmmry, RvSmmry As String Dim CmtAuArr() As String Dim RvAuArr() As String Dim strType, strPage, strAuthor, strSort As String Dim CmtMkrs As New Collection, a Dim RvMkrs As New Collection, g sCmAuTxt1 = "The following people have made comments:" & vbNewLine & vbNewLine: sCmAuTxt2 = vbNewLine & "Enter the name of the ": sCmAuTxt3 = "commenter to exclude, exactly as it appears above (without the list number)." & vbNewLine & vbNewLine & "Leaving this box empty will exit the macro.": sCmAuTxt4 = " reviewer to exclude" sRvAuTxt1 = "The following people have made tracked insertions or deletions:" & vbNewLine & vbNewLine: sRvAuTxt2 = vbNewLine & "Enter the name of the ": sRvAuTxt3 = "reviewer to exclude, exactly as it appears above." & vbNewLine & vbNewLine & "Leaving this box empty will exit the macro.": sRvAuTxt4 = " reviewer to exclude" Title = "Comment and revision tracker" n = 0 rCount2 = 0 Set oDoc = ActiveDocument nCount = ActiveDocument.Comments.Count rCount = oDoc.Revisions.Count Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory For w = 1 To rCount Selection.NextRevision If Selection.Range.Revisions(1).Type = wdRevisionDelete Or wdRevisionInsert Then rCount2 = rCount2 + 1 Else GoTo Nextw End If Nextw: Next w Selection.HomeKey Unit:=wdStory Application.ScreenUpdating = True If nCount = 0 Then initCSum = "" ElseIf nCount > 0 Then initCSum = "There are " & nCount & " comments in this document." & vbNewLine & vbNewLine End If If rCount2 = 0 Then initRSum = "" ElseIf rCount2 > 0 Then initRSum = "There are " & rCount2 & " eligible tracked insertions and deletions in this document." & vbNewLine & vbNewLine End If If (nCount = 0) And (rCount2 = 0) Then MsgBox "There are no comments or revisions to extract.", vbOKOnly + vbCritical, Title GoTo ExitHere End If If MsgBox("This macro can extract comments and tracked insertions" & vbNewLine & "or deletions but not other types of tracked changes." _ & vbNewLine & vbNewLine & initCSum & initRSum & "Continue?", vbYesNo) = vbNo Then GoTo ExitHere If (rCount2 = 0) And (nCount > 0) Then finSel = "Comments" RvSmmry = "" GoTo ExclAuth ElseIf (rCount2 > 0) And (nCount = 0) Then finSel = "Tracks" CmntSmmry = "" GoTo Start ElseIf (rCount2 > 0) And (nCount > 0) Then selType = MsgBox("Do you want to extract both comments and revisions*?" & vbNewLine & vbNewLine & "Yes:" & vbTab & "Extract both" & vbNewLine & "No:" & vbTab & "To choose which to extract" & vbNewLine & "Cancel:" & vbTab & "To exit" & vbNewLine & vbNewLine & "*Only insertions and deletions will be extracted", vbYesNoCancel, "Customise extraction") If selType = vbCancel Then GoTo ExitHere ElseIf selType = vbYes Then finSel = "Both" ElseIf selType = vbNo Then selType2 = MsgBox("Do you want to extract comments or revisions?" & vbNewLine & vbNewLine & "Yes:" & vbTab & "Extract comments" & vbNewLine & "No:" & vbTab & "Extract revisions*" & vbNewLine & "Cancel:" & vbTab & "To exit" & vbNewLine & vbNewLine & "*Only insertions and deletions will be extracted", vbYesNoCancel, "Choose comments or revisions") If selType2 = vbCancel Then GoTo ExitHere ElseIf selType2 = vbYes Then finSel = "Comments" RvSmmry = "" ElseIf selType2 = vbNo Then finSel = "Tracks" CmntSmmry = "" End If End If End If ExclAuth: If Not finSel = "Tracks" Then blDimensioned = False For n = 1 To nCount stCmtAuth = ActiveDocument.Comments(n).Author If stCmtAuth <> "" Then If blDimensioned = True Then ReDim Preserve CmtAuArr(0 To UBound(CmtAuArr) + 1) As String Else ReDim CmtAuArr(0 To 0) As String CmtAuArr(0) = "" blDimensioned = True End If CmtAuArr(UBound(CmtAuArr)) = stCmtAuth End If Next sAllCmtAus = "" On Error Resume Next For Each a In CmtAuArr CmtMkrs.Add a, a Next For cax = 1 To CmtMkrs.Count sAllCmtAus = sAllCmtAus & cax & ". " & CmtMkrs(cax) & vbNewLine Next Erase CmtAuArr If CmtMkrs.Count > 5 Then CmtMax = 5 CmtMaxOp = "You can exclude comments from a maximum of 5 people." ElseIf CmtMkrs.Count <= 5 Then CmtMax = CmtMkrs.Count - 1 End If If CmtMax > 1 Then CmtMaxOp = "You can exclude comments from a maximum of " & CmtMax & " people." ElseIf CmtMax = 1 Then CmtMaxOp = "As there are only comments from 2 people, you can" & vbNewLine & "only choose to exclude a maximum of 1 person." ElseIf CmtMax = 0 Then CmtOne = MsgBox("There are only comments from 1 person, so you can't exclude any authors from the tracker.", vbOKCancel) If CmtOne = vbCancel Then GoTo ExitHere Else GoTo Start End If End If CmtAuNum = CmtMkrs.Count exAuth = MsgBox("There are comments from " & CmtAuNum & " different people." & vbNewLine & vbNewLine & "Do you want to exclude any commenters?", vbYesNoCancel + vbInformation, "Exclude authors") If exAuth = vbNo Then CmntSmmry = "All " & nCount & " comments from " & CmtAuNum & " authors were extracted." & vbNewLine & vbNewLine cTb = nCount If finSel = "Comments" Then GoTo Start ElseIf finSel = "Both" Then GoTo ExclRev End If ElseIf exAuth = vbCancel Then GoTo ExitHere ElseIf exAuth = vbYes Then ChooseAuNum: If CmtMax = 1 Then exAuthNum = MsgBox(CmtMaxOp & vbNewLine & vbNewLine & "Click CANCEL to exit.", vbOKCancel, "Exclude author") If exAuthNum = vbOK Then exAuthNum = 1 ElseIf exAuthNum = vbCancel Then GoTo ExitHere End If ElseIf CmtMax = 2 Or 3 Or 4 Or 5 Then exAuthNum = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & CmtMaxOp & vbNewLine & vbNewLine & "Enter the number of people to exclude below", "Number to exclude") End If If (exAuthNum = 0) Or (exAuthNum = "") Then AuNumRet = MsgBox("Do you want to continue without excluding any authors?" & vbNewLine & vbNewLine & "Click YES to proceed without excluding an author." & vbNewLine & vbNewLine & "Press NO to go back and input a valid number." & vbNewLine & vbNewLine & "Press CANCEL to exit", vbYesNoCancel + vbQuestion, "Error!") If AuNumRet = vbCancel Then GoTo ExitHere ElseIf AuNumRet = vbYes Then CmntSmmry = "All " & nCount & " comments from " & CmtAuNum & " authors were extracted." & vbNewLine & vbNewLine GoTo Start ElseIf AuNumRet = vbNo Then GoTo ChooseAuNum End If ElseIf (exAuthNum > CmtMaxOp) Or (IsNumeric(exAuthNum) = False) Then AuNumRet = MsgBox("You have entered an invalid value." & vbNewLine & vbNewLine & "Click RETRY to try again or CANCEL to exit", vbRetryCancel + vbCritical, "Error!") If AuNumRet = vbCancel Then GoTo ExitHere ElseIf AuNumRet = vbRetry Then GoTo ChooseAuNum End If End If If exAuthNum = 1 Then Auth2ex1 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & sCmAuTxt3, "Author to exclude") If Auth2ex1 = "" Then End Auth2ex2 = "Null and void": Auth2ex3 = "Null and void": Auth2ex4 = "Null and void": Auth2ex5 = "Null and void" ElseIf exAuthNum = 2 Then Auth2ex1 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "1st " & sCmAuTxt3, "1st " & sCmAuTxt4) If Auth2ex1 = "" Then End Auth2ex2 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "2nd " & sCmAuTxt3, "2nd " & sCmAuTxt4) If Auth2ex2 = "" Then End Auth2ex3 = "Null and void": Auth2ex4 = "Null and void": Auth2ex5 = "Null and void" ElseIf exAuthNum = 3 Then Auth2ex1 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "1st " & sCmAuTxt3, "1st " & sCmAuTxt4) If Auth2ex1 = "" Then End Auth2ex2 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "2nd " & sCmAuTxt3, "2nd " & sCmAuTxt4) If Auth2ex2 = "" Then End Auth2ex3 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "3rd " & sCmAuTxt3, "3rd " & sCmAuTxt4) If Auth2ex3 = "" Then End Auth2ex4 = "Null and void": Auth2ex5 = "Null and void" ElseIf exAuthNum = 4 Then Auth2ex1 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "1st " & sCmAuTxt3, "1st " & sCmAuTxt4) If Auth2ex1 = "" Then End Auth2ex2 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "2nd " & sCmAuTxt3, "2nd " & sCmAuTxt4) If Auth2ex2 = "" Then End Auth2ex3 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "3rd " & sCmAuTxt3, "3rd " & sCmAuTxt4) If Auth2ex3 = "" Then End Auth2ex4 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "4th " & sCmAuTxt3, "4th " & sCmAuTxt4) If Auth2ex4 = "" Then End Auth2ex5 = "Null and void" ElseIf exAuthNum = 5 Then Auth2ex1 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "1st " & sCmAuTxt3, "1st " & sCmAuTxt4) If Auth2ex1 = "" Then End Auth2ex2 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "2nd " & sCmAuTxt3, "2nd " & sCmAuTxt4) If Auth2ex2 = "" Then End Auth2ex3 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "3rd " & sCmAuTxt3, "3rd " & sCmAuTxt4) If Auth2ex3 = "" Then End Auth2ex4 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "4th " & sCmAuTxt3, "4th " & sCmAuTxt4) If Auth2ex4 = "" Then End Auth2ex5 = InputBox(sCmAuTxt1 & sAllCmtAus & vbNewLine & sCmAuTxt2 & "5th " & sCmAuTxt3, "5th " & sCmAuTxt4) If Auth2ex5 = "" Then End Else End End If End If CommCount: If exAuthNum = 1 Then CmntCnter = vbCr: cmCounter = Array(Auth2ex1) ElseIf exAuthNum = 2 Then CmntCnter = vbCr: cmCounter = Array(Auth2ex1, Auth2ex2) ElseIf exAuthNum = 3 Then CmntCnter = vbCr: cmCounter = Array(Auth2ex1, Auth2ex2, Auth2ex3) ElseIf exAuthNum = 4 Then CmntCnter = vbCr: cmCounter = Array(Auth2ex1, Auth2ex2, Auth2ex3, Auth2ex4) ElseIf exAuthNum = 5 Then CmntCnter = vbCr: cmCounter = Array(Auth2ex1, Auth2ex2, Auth2ex3, Auth2ex4, Auth2ex5) End If For b = LBound(cmCounter) To UBound(cmCounter) c = 0 For d = 1 To nCount With oDoc.Comments(d) If .Author = cmCounter(b) Then c = c + 1 End With Next Next sCmtTally = nCount - c: cTb = nCount - c CmntSmmry = "Extracted:" & vbTab & vbTab & vbTab & sCmtTally & " comments from " & (CmtAuNum - exAuthNum) & " authors." & vbNewLine & "Total in document:" & vbTab & vbTab & nCount & " comments from " & CmtAuNum & " authors." & vbNewLine & vbNewLine End If If finSel = "Comments" Then GoTo Start ExclRev: If Not finSel = "Comments" Then blDimensioned = False Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory For x = 1 To rCount Selection.NextRevision If Selection.Range.Revisions(1).Type = wdRevisionDelete Or wdRevisionInsert Then With Selection.Range.Revisions(1) stRvAuth = .Author If stRvAuth <> "" Then If blDimensioned = True Then ReDim Preserve RvAuArr(0 To UBound(RvAuArr) + 1) As String Else ReDim RvAuArr(0 To 0) As String RvAuArr(0) = "" blDimensioned = True End If RvAuArr(UBound(RvAuArr)) = stRvAuth End If End With End If Next x sAllRvAus = "" On Error Resume Next For Each g In RvAuArr RvMkrs.Add g, g Next For rax = 1 To RvMkrs.Count sAllRvAus = sAllRvAus & rax & ". " & RvMkrs(rax) & vbNewLine Next Erase RvAuArr If RvMkrs.Count > 5 Then RvMax = 5 RvMaxOp = "You can exclude tracked insertions or deletions from a maximum of 5 people." ElseIf RvMkrs.Count <= 5 Then RvMax = RvMkrs.Count - 1 End If If RvMax > 1 Then RvMaxOp = "You can exclude tracked insertions or deletions from a maximum of " & RvMax & " people." ElseIf RvMax = 1 Then RvMaxOp = "As there are only tracked insertions or deletions from 2 people, you can" & vbNewLine & "only choose to exclude a maximum of 1 person." ElseIf RvMax = 0 Then RvOne = MsgBox("There are only tracked insertions or deletions from 1 person, so you can't exclude any reviewers from the tracker.", vbOKCancel) If RvOne = vbCancel Then GoTo ExitHere Else GoTo Start End If End If RvAuNum = RvMkrs.Count exRev = MsgBox("There are tracked insertions or deletions from " & RvAuNum & " different people." & vbNewLine & vbNewLine & "Do you want to exclude any reviewers?", vbYesNoCancel + vbInformation, "Exclude reviewers") If exRev = vbNo Then RvSmmry = "All " & rCount2 & " tracked insertions or deletions from " & RvAuNum & " people were extracted." & vbNewLine & vbNewLine rTb = rCount2 GoTo Start ElseIf exRev = vbCancel Then GoTo ExitHere ElseIf exRev = vbYes Then ChooseRevNum: If RvMax = 1 Then exRevNum = MsgBox(RvMaxOp & vbNewLine & vbNewLine & "Click CANCEL to exit.", vbOKCancel, "Exclude reviewer") If exRevNum = vbOK Then exRevNum = 1 ElseIf exRevNum = vbCancel Then GoTo ExitHere End If ElseIf RvMax = 2 Or 3 Or 4 Or 5 Then exRevNum = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & RvMaxOp & vbNewLine & vbNewLine & "Enter the number of people to exclude below", "Number to exclude") End If If (exRevNum = 0) Or (exRevNum = "") Then RevNumRet = MsgBox("Do you want to continue without excluding any reviewers?" & vbNewLine & vbNewLine & "Click YES to proceed without excluding a reviewer." & vbNewLine & vbNewLine & "Press NO to go back and input a valid number." & vbNewLine & vbNewLine & "Press CANCEL to exit", vbYesNoCancel + vbQuestion, "Error!") If RevNumRet = vbCancel Then GoTo ExitHere ElseIf RevNumRet = vbYes Then RvSmmry = "All " & rCount2 & " tracked insertions or deletions from " & RvAuNum & " people were extracted." & vbNewLine & vbNewLine rTb = rCount2 GoTo Start ElseIf RevNumRet = vbNo Then GoTo ChooseRevNum End If ElseIf (exRevNum > RvMaxOp) Or (IsNumeric(exRevNum) = False) Then RevNumRet = MsgBox("You have entered an invalid value." & vbNewLine & vbNewLine & "Click RETRY to try again or CANCEL to exit", vbRetryCancel + vbCritical, "Error!") If RevNumRet = vbCancel Then GoTo ExitHere ElseIf RevNumRet = vbRetry Then GoTo ChooseRevNum End If End If If exRevNum = 1 Then Rev2ex1 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & sRvAuTxt3, "Reviewer to exclude") If Rev2ex1 = "" Then End Rev2ex2 = "Null and void": Rev2ex3 = "Null and void": Rev2ex4 = "Null and void": Rev2ex5 = "Null and void" ElseIf exRevNum = 2 Then Rev2ex1 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "1st " & sRvAuTxt3, "1st " & sRvAuTxt4) If Rev2ex1 = "" Then End Rev2ex2 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "2nd " & sRvAuTxt3, "2nd " & sRvAuTxt4) If Rev2ex2 = "" Then End Rev2ex3 = "Null and void": Rev2ex4 = "Null and void": Rev2ex5 = "Null and void" ElseIf exRevNum = 3 Then Rev2ex1 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "1st " & sRvAuTxt3, "1st " & sRvAuTxt4) If Rev2ex1 = "" Then End Rev2ex2 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "2nd " & sRvAuTxt3, "2nd " & sRvAuTxt4) If Rev2ex2 = "" Then End Rev2ex3 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "3rd " & sRvAuTxt3, "3rd " & sRvAuTxt4) If Rev2ex3 = "" Then End Rev2ex4 = "Null and void": Rev2ex5 = "Null and void" ElseIf exRevNum = 4 Then Rev2ex1 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "1st " & sRvAuTxt3, "1st " & sRvAuTxt4) If Rev2ex1 = "" Then End Rev2ex2 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "2nd " & sRvAuTxt3, "2nd " & sRvAuTxt4) If Rev2ex2 = "" Then End Rev2ex3 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "3rd " & sRvAuTxt3, "3rd " & sRvAuTxt4) If Rev2ex3 = "" Then End Rev2ex4 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "4th " & sRvAuTxt3, "4th " & sRvAuTxt4) If Rev2ex4 = "" Then End Rev2ex5 = "Null and void" ElseIf exRevNum = 5 Then Rev2ex1 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "1st " & sRvAuTxt3, "1st " & sRvAuTxt4) If Rev2ex1 = "" Then End Rev2ex2 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "2nd " & sRvAuTxt3, "2nd " & sRvAuTxt4) If Rev2ex2 = "" Then End Rev2ex3 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "3rd " & sRvAuTxt3, "3rd " & sRvAuTxt4) If Rev2ex3 = "" Then End Rev2ex4 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "4th " & sRvAuTxt3, "4th " & sRvAuTxt4) If Rev2ex4 = "" Then End Rev2ex5 = InputBox(sRvAuTxt1 & sAllRvAus & vbNewLine & sRvAuTxt2 & "5th " & sRvAuTxt3, "5th " & sRvAuTxt4) If Rev2ex5 = "" Then End Else End End If End If RevCount: If exRevNum = 1 Then RevCnter = vbCr: revCounter = Array(Rev2ex1) ElseIf exRevNum = 2 Then RevCnter = vbCr: revCounter = Array(Rev2ex1, Rev2ex2) ElseIf exRevNum = 3 Then RevCnter = vbCr: revCounter = Array(Rev2ex1, Rev2ex2, Rev2ex3) ElseIf exRevNum = 4 Then RevCnter = vbCr: revCounter = Array(Rev2ex1, Rev2ex2, Rev2ex3, Rev2ex4) ElseIf exRevNum = 5 Then RevCnter = vbCr: revCounter = Array(Rev2ex1, Rev2ex2, Rev2ex3, Rev2ex4, Rev2ex5) End If For j = LBound(revCounter) To UBound(revCounter) k = 0 Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory For y = 1 To rCount Selection.NextRevision If (Selection.Range.Revisions(1).Type = wdRevisionDelete Or wdRevisionInsert) _ And (Selection.Range.Revisions(1).Author = revCounter(j)) Then k = k + 1 Next y Next j Selection.HomeKey Unit:=wdStory Application.ScreenUpdating = True sRevTally = rCount2 - k: rTb = rCount2 = k RvSmmry = "Extracted:" & vbTab & vbTab & vbTab & sRevTally & " revisions from " & (RvAuNum - exRevNum) & " reviewers." & vbNewLine & "Total in document:" & vbTab & vbTab & rCount2 & " tracked insertions or deletions from" & vbNewLine & vbTab & vbTab & vbTab & RvAuNum & " people." & vbNewLine & vbNewLine End If Start: MsgBox "Word may appear to freeze during this process!" & vbNewLine & vbNewLine & "Don't panic! Word has not crashed. Just wait for the process to finish." & vbNewLine & vbNewLine & "The more revisions and comments there are, the longer the process will take.", vbOKOnly, "DON'T PANIC!" Application.ScreenUpdating = False Set oNewDoc = Documents.Add oNewDoc.PageSetup.Orientation = wdOrientLandscape With oNewDoc .Content = "" If finSel = "Comments" Then Set oTable = .Tables.Add _ (Range:=Selection.Range, _ numRows:=cTb + 1, _ NumColumns:=7) ElseIf finSel = "Tracks" Then Set oTable = .Tables.Add _ (Range:=Selection.Range, _ numRows:=rTb + 1, _ NumColumns:=7) ElseIf finSel = "Both" Then Set oTable = .Tables.Add _ (Range:=Selection.Range, _ numRows:=cTb + rTb + 1, _ NumColumns:=7) End If End With If finSel = "Comments" Then oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _ "Comments extracted from: " & oDoc.Name ElseIf finSel = "Tracks" Then oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _ "Revisions extracted from: " & oDoc.Name ElseIf finSel = "Both" Then oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _ "Comments and revisions extracted from: " & oDoc.Name End If With oNewDoc.Styles(wdStyleNormal) .Font.Name = "Calibri" .Font.Size = 9 .ParagraphFormat.LeftIndent = 0 .ParagraphFormat.SpaceAfter = 6 End With With oNewDoc.Styles(wdStyleHeader) .Font.Size = 8 .ParagraphFormat.SpaceAfter = 0 End With With oTable .Range.Style = wdStyleNormal .AllowAutoFit = False .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 .Columns.PreferredWidthType = wdPreferredWidthPercent .Columns(1).PreferredWidth = 5 .Columns(2).PreferredWidth = 10 .Columns(3).PreferredWidth = 25 .Columns(4).PreferredWidth = 25 .Columns(5).PreferredWidth = 15 .Columns(6).PreferredWidth = 30 .Columns(7).PreferredWidth = 2 .Rows(1).HeadingFormat = True End With With oTable.Rows(1) .Range.Font.Bold = True .Cells(1).Range.Text = "Page" .Cells(2).Range.Text = "Type" .Cells(3).Range.Text = "Comment" .Cells(4).Range.Text = "Relevant text" .Cells(5).Range.Text = "Commenter" .Cells(6).Range.Text = "Action/response" .Cells(7).Range.Text = "Sort" End With If (finSel = "Both" Or finSel = "Comments") Then GoTo Comments Else If finSel = "Tracks" Then GoTo Tracks End If End If Comments: For n = 1 To nCount If (oDoc.Comments(n).Author = Auth2ex1) Or (oDoc.Comments(n).Author = Auth2ex2) Or (oDoc.Comments(n).Author = Auth2ex3) Or (oDoc.Comments(n).Author = Auth2ex4) Or (oDoc.Comments(n).Author = Auth2ex5) Then GoTo NextN Else With oTable.Rows(n + 1) .Cells(1).Range.Text = _ oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber) .Cells(2).Range.Text = "Comment" .Cells(3).Range.Text = oDoc.Comments(n).Range.Text .Cells(4).Range.Text = oDoc.Comments(n).Scope .Cells(5).Range.Text = oDoc.Comments(n).Author .Cells(7).Range.Text = oDoc.Comments(n).Scope.Information(wdFirstCharacterLineNumber) End With GoTo NextN End If NextN: Next n If finSel = "Comments" Then GoTo Finalise Else GoTo Tracks End If Tracks: Selection.HomeKey Unit:=wdStory For z = 1 To rCount Selection.NextRevision With Selection.Range.Revisions(1) If (.Type <> wdRevisionDelete Or wdRevisionInsert) Or (.Author = (Rev2ex1 Or Rev2ex2 Or Rev2ex3 Or Rev2ex4 Or Rev2ex5)) Then GoTo Nextz Else Select Case .Type Case wdRevisionInsert strPage = .Range.Information(wdActiveEndPageNumber) strType = "Insert" strAuthor = .Author strSort = .Range.Information(wdFirstCharacterLineNumber) strText = .Range.Text oRange = .Range Do While InStr(1, oRange.Text, Chr(2)) > 0 i = InStr(1, strText, Chr(2)) If oRange.Footnotes.Count = 1 Then strText = Replace(Expression:=strText, _ Find:=Chr(2), Replace:="[footnote reference]", _ Start:=1, Count:=1) oRange.Start = oRange.Start + i ElseIf oRange.Endnotes.Count = 1 Then strText = Replace(Expression:=strText, _ Find:=Chr(2), Replace:="[endnote reference]", _ Start:=1, Count:=1) oRange.Start = oRange.Start + i End If Loop Set oRows = oTable.Rows.Add With oRows .Cells(1).Range.Text = strPage With .Cells(2).Range .Text = strType .Font.Color = wdColorBlue End With With .Cells(4).Range .Text = strText .Font.Color = wdColorBlue End With .Cells(5).Range.Text = strAuthor .Cells(7).Range.Text = strSort End With Case wdRevisionInsert strPage = .Range.Information(wdActiveEndPageNumber) strType = "Delete" strAuthor = .Author strSort = .Range.Information(wdFirstCharacterLineNumber) strText = .Range.Text oRange = .Range Do While InStr(1, oRange.Text, Chr(2)) > 0 i = InStr(1, strText, Chr(2)) If oRange.Footnotes.Count = 1 Then strText = Replace(Expression:=strText, _ Find:=Chr(2), Replace:="[footnote reference]", _ Start:=1, Count:=1) oRange.Start = oRange.Start + i ElseIf oRange.Endnotes.Count = 1 Then strText = Replace(Expression:=strText, _ Find:=Chr(2), Replace:="[endnote reference]", _ Start:=1, Count:=1) oRange.Start = oRange.Start + i End If Loop Set oRows = oTable.Rows.Add With oRows .Cells(1).Range.Text = strPage With .Cells(2).Range .Text = strType .Font.Color = wdColorRed End With With .Cells(4).Range .Text = strText .Font.Color = wdColorRed End With .Cells(5).Range.Text = strAuthor .Cells(7).Range.Text = strSort End With End Select End If End With Nextz: Next z Finalise: Set myTable = ActiveDocument.Tables(1) With myTable.Borders .InsideLineStyle = wdLineStyleSingle .OutsideLineStyle = wdLineStyleSingle End With ActiveDocument.Tables(1).Select Selection.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _ :=wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, FieldNumber2:= _ "Column 7", SortFieldType2:=wdSortFieldNumeric, SortOrder2:= _ wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _ wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _ wdSortSeparateByCommas, SortColumn:=False, CaseSensitive:=False, _ LanguageID:=wdEnglishUK, SubFieldNumber:="Paragraphs", SubFieldNumber2:= _ "Paragraphs", SubFieldNumber3:="Paragraphs" Selection.Columns(7).Delete With ActiveDocument.Tables(1) noCol = .Range.Rows(1).Cells.Count For blRows = .Rows.Count To 1 Step -1 With .Rows(blRows) If Len(.Range) = noCol * 2 + 2 Then .Delete End With Next blRows End With Application.ScreenUpdating = True Application.ScreenRefresh oNewDoc.Activate MsgBox CmntSmmry & RvSmmry & "Finished creating tracker.", vbOKOnly + vbInformation, "Job summary" ExitHere: Set oDoc = Nothing Set oNewDoc = Nothing Set oTable = Nothing End Sub
Reply With Quote
Originally Posted by Kilroy
