Final hurdle for combined comment and revision grid

[h2whoa]

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

[macropod]

Instead of trying to combine everything into a single code module, you should have three modules; one for the revisions; one for the comments; and one for the decision-making that calls either/both of the others as appropriate. Where necessary, the first two should use their own variables (e.g. for counters); you can use global variables for things like the names if they're to be shared by the first two modules.

[h2whoa]

Ah, interesting. I'm still an amateur just tweaking things without a deep understanding, so hadn't considered separating it into three modules. Appreciate your help. I'll give this a try.

So, if my decision module gets the Author names held in a String, like Auth2ex1, how would I pass that value into the next module (i.e. the comment module)?

Thanks again.

[macropod]

For example:

Dim StrAuth As String, i As Long

Sub Main()
Dim Rslt
StrAuth = InputBox("Input Authors, separated by | (e.g. AuthA|AuthB)")
Select Case MsgBox("Process OptionA = Yes" & vbCr & "Process OptionB = No" & vbCr & "Process OptionB = Cancel", vbYesNoCancel)
Case vbYes: MsgBox "You chose OptionA": Call OptionA
Case vbNo: MsgBox "You chose OptionB": Call OptionB
Case vbCancel: MsgBox "You chose OptionA & OptionB": Call OptionA: Call OptionB
End Select
End Sub

Sub OptionA()
For i = 0 To UBound(Split(StrAuth, "|"))
MsgBox " OptionA " & Split(StrAuth, "|")(i)
Next
End Sub

Sub OptionB()
For i = 0 To UBound(Split(StrAuth, "|"))
MsgBox " OptionB " & Split(StrAuth, "|")(i)
Next
End Sub

[Kilroy]

H2Whoa what an amazing and useful tool this would be. I hope someone can figure out the table population issue.

[h2whoa]

Great, thanks Paul. I'll give this a whirl.

Cheers.

[h2whoa]

H2Whoa what an amazing and useful tool this would be. I hope someone can figure out the table population issue.

I'll keep you posted! I feel like it's nearly there.

[Kilroy]

Try this. in the Comments section:


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
oTable.Rows.Add
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


I just added " oTable.Rows.Add"

[Kilroy]

Unfortunately it is not populating the table with the tracked changes, just the comments are working. I'll look at it more when I get home from work.

[macropod]

You might be interested in the revision & comment extraction macros I posted at: https://answers.microsoft.com/en-us/office/forum/office_2007-word/possible-to-export-word-track-changes-information/e0dee9dc-aedb-41d3-92bf-8dc609cc75af. See my posts of November 3, 2014 & September 5, 2015, respectively.

[h2whoa]

Unfortunately it is not populating the table with the tracked changes, just the comments are working. I'll look at it more when I get home from work.

Yeah, it's so frustrating. I just don't know why it's refusing to cooperate with the tracked changes! Will also take a look at macropod's macros.

[Kilroy]

I couldn't figure it out but I did put this together today. No options but it works.


Sub CommentsAndRevisionsToTable()
'Kilroy
Dim s As String
Dim r As String
Dim cmt As Word.Comment
Dim doc As Word.Document
Dim rev As Word.Revision
Dim oTbl As Table
For Each cmt In ActiveDocument.Comments
s = s & cmt.Author & (",Comment " & cmt.Index) & "," & cmt.range.Text & vbCr
Next
For Each rev In ActiveDocument.Revisions
r = r & rev.Author & (",Revision " & rev.Index) & "," & rev.range.Text & vbCr
Next
Set doc = Documents.Add
doc.range.Text = s & r
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByCommas, NumColumns:=3, _
numRows:=12, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If

End With
Selection.InsertRowsAbove 1
With Selection.Tables(1).Columns(3)
.Select
Selection.InsertColumnsRight
End With
With Selection.Tables(1)
.Columns(1).SetWidth ColumnWidth:=100, _
RulerStyle:=wdAdjustFirstColumn
.Columns(2).SetWidth ColumnWidth:=100, _
RulerStyle:=wdAdjustFirstColumn
.Columns(3).SetWidth ColumnWidth:=100, _
RulerStyle:=wdAdjustFirstColumn
.Columns(4).SetWidth ColumnWidth:=100, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).range.Text = "Author"
.Cell(1, 2).range.Text = "Edit Type"
.Cell(1, 3).range.Text = "Comment/Revision"
.Cell(1, 4).range.Text = "Acceptable?"
End With
End Sub

[Kilroy]

I know VBA can't tell what a "sentence" is but is there a way to include in the revision portion, an entire sentence using something like selection.start and selection.end? Ist here something else?

[h2whoa]

Interesting idea. And thanks for the code. Will take a look today.

[Kilroy]

Really the most ideal layout would include the before and after "sentence".

[h2whoa]

Update:

I have had a significant breakthrough with this. I need to tidy up a few things as I'd be embarrassed to post the code in it's current working form, but I have actually managed to get it working. Furthermore, in my updated code the only limit on the number of people you can choose to exclude is the number of reviewers and commenters in the document. I'll post the code in the next couple of days.

[h2whoa]

Well. Here we go. Wow, this has had me smashing my head into my desk on numerous occasions. It's not pretty, but it seems to work. Three things to consider:



I'm quite sure that this is not 'pretty' and that somebody who actually knows what they are doing would be able to make this much more elegant than my fudge.
This will only extract comments and tracked text insertions or deletions. During the course of this I found out that revision handling isn't great in VBA, so I had to add a Like test for revisions to only select text ranges to prevent failures.
If your document is large and/or contains extensive revisions, Word may appear to freeze at various points in this process. In the last stage, when it's building the table, Word may appear to lock up for a good few minutes, especially if there are lots of revisions. This is normal. Just leave it to run and it will get there.


As mentioned in the top post of this thread, I'm indebted to the brains and helpfulness of others for getting me to this point. If you have any ideas for tidying up this behemoth and making it more efficient, please just let me know!

As suggested by macropod, I've split this out into a number of subs, each one handling a specific part of the process.



'Public declarations

Public cmInc, cmEx, comSkip, revInc, revEx, revSkip As Boolean
Public cmSummary, revSummary, scrllPs As String
Public nCount, lAn, lFAn, cmTally, _
rCount, indelCount, lRn, lFRevn, revTally As Long
Public crsRng As Range
Public nc2, rev2exN As Integer
Public Cmt2ex As New Collection, cd
Public Review2ex As New Collection, rd
Public Cmt2exArr() As String
Public Rev2exArr() As String
Public oDoc As Document




Public Sub Comment_And_InDel_Grid()
i_Reset_Pub_Decs
ii_Com_Analyse
iii_Rev_Analyse
iv_Grid_maker
End Sub




Public Sub i_Reset_Pub_Decs()
cmInc = False: cmEx = False: comSkip = False: revInc = False: revEx = False: revSkip = False


cmSummary = "": revSummary = "": scrllPs = ""
nCount = 0: lAn = 0: lFAn = 0: cmTally = 0: rCount = 0: indelCount = 0: lRn = 0: lFRevn = 0: revTally = 0


Set crsRng = Nothing
nc2 = 0: rev2exN = 0
Set Cmt2ex = Nothing
Set Review2ex = Nothing
Erase Cmt2exArr
Erase Rev2exArr


Set oDoc = Nothing


End Sub




Public Sub ii_Com_Analyse()


Dim b, c, e, g, h, i, j As Long
Dim sCmAuTxt1, initCSum, chsEx, stCmtAuth, sTCmAs, _
rtrn2ex, rtrn2exsel, cmtMax, selComs, stSkpRv, C2X As String
Dim CmtAuArr() As String
Dim CmtCol As New Collection, ca


sCmAuTxt1 = "The following people have made comments:" & vbNewLine & vbNewLine


Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
rCount = ActiveDocument.Revisions.Count
cmInc = False
comSkip = False
Set crsRng = Selection.Range
scrllPs = ActiveWindow.ActivePane.VerticalPercentScrolled

If (nCount = 0) And (rCount > 0) Then
MsgBox "There are no comments in this document.", vbOKOnly + vbCritical
cmInc = False: cmEx = False: comSkip = True
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo Revcheck
ElseIf (nCount = 0) And (rCount = 0) Then
MsgBox "There are no comments or changes in this document in this document.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
ElseIf nCount = 1 Then
initCSum = "There is only one comment in this document." & vbNewLine & vbNewLine & "Do you want to include this in the tracker?"
lAn = 1
cmtMax = "There is only one author, so you can't exclude them from the tracker."
ElseIf nCount > 1 Then
'Compiles a list of people who have made comments in the document
blDimensioned = False
For b = 1 To nCount
stCmtAuth = ActiveDocument.Comments(b).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

'Collects and counts authors
On Error Resume Next
For Each ca In CmtAuArr
CmtCol.Add ca, ca
Next

lAn = CmtCol.Count

'Commenter exclusion text building
If CmtCol.Count = 1 Then
cmtMax = "There is only one author, so you can't exclude them from the tracker."
initCSum = "There are " & nCount & " comments from " & CmtCol(1) & "." & vbNewLine & vbNewLine & "Do you want to include comments in the tracker?"
ElseIf CmtCol.Count > 1 Then
sTCmAs = ""
For c = 1 To lAn
sTCmAs = sTCmAs & c & ". " & CmtCol(c) & vbNewLine
Next

initCSum = "There are " & nCount & " comments from " & lAn & " people." & vbNewLine & sCmAuTxt1 & sTCmAs & vbNewLine _
& vbNewLine & "Do you want to include comments in the tracker?"

If CmtCol.Count > 2 Then
lFAn = CmtCol.Count - 1
cmtMax = "You can exclude comments from a maximum of " & lFAn & " people." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
ElseIf CmtCol.Count = 2 Then
lFAn = 1
cmtMax = "You can exclude comments from a maximum of one person." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
End If
End If
End If

'Decide whether to include comments in the tracker
selComs = MsgBox(initCSum, vbYesNo + vbQuestion)

If selComs = vbYes Then
cmInc = True
ElseIf selComs = vbNo Then
comSkip = True: cmInc = False: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo Revcheck
End If
Revcheck:
If rCount > 0 Then
stSkpRv = MsgBox("Will you also want to process tracked changes?", vbYesNo + vbQuestion)
If stSkpRv = vbYes Then
revSkip = False: revInc = True
ElseIf stSkpRv = vbNo Then
revSkip = True
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
End If
If comSkip = True Then GoTo EndComCount
ElseIf rCount = 0 Then
MsgBox "There are no tracked changes in this document. Only comments will be extracted.", vbOKOnly + vbInformation
revSkip = True
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
End If

If lAn = 1 Then
If MsgBox(cmtMax, vbOKCancel + vbInformation) = vbOK Then
cmInc = True: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
cmSummary = "All " & nCount & " comments from " & CmtCol(1) & " extracted."
GoTo EndComCount
Else
cmInc = False: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo EndComCount
End If
Else
'Choose whether to exclude any commenters
chsEx = MsgBox(sCmAuTxt1 & sTCmAs & vbNewLine & cmtMax, vbYesNoCancel)
If chsEx = vbYes Then
cmEx = True
n2ex:
'Choose number of commenters to exclude
nc2 = InputBox(sCmAuTxt1 & sTCmAs & vbNewLine & "How many people do you want to exclude?" & vbNewLine & vbNewLine & "Maximum of " & lFAn & ".", "Number to exclude")

'Number validity testing
If (IsNumeric(nc2) = False) Or (nc2 > (CmtCol.Count - 1)) Or (nc2 = 0) Then
rtrn2ex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2ex = vbRetry Then
GoTo n2ex

ElseIf rtrn2ex = vbAbort Then
cmInc = False: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo EndComCount

ElseIf rtrn2ex = vbIgnore Then
cmInc = True: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
cmSummary = "All " & nCount & " comments extracted."
GoTo EndComCount
End If
Else
'Build user-defined list of commenters to exclude
blDimensioned = False
For e = 1 To nc2
Exn:
j = InputBox(sCmAuTxt1 & sTCmAs & vbNewLine & "Enter the number of the person to exclude, from the list above.")
If (j > CmtCol.Count) Or (j = 0) Or (IsNumeric(j) = False) Then
rtrn2exsel = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2exsel = vbRetry Then
GoTo Exn

ElseIf rtrn2exsel = vbAbort Then
cmInc = False: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo EndComCount

ElseIf rtrn2exsel = vbIgnore Then
cmInc = True: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
cmSummary = "All " & nCount & " comments extracted."
GoTo EndComCount
End If
Else

C2X = CmtCol(j)


If blDimensioned = True Then
ReDim Preserve Cmt2exArr(0 To UBound(Cmt2exArr) + 1) As String
Else
ReDim Cmt2exArr(0 To 0) As String
Cmt2exArr(0) = ""
blDimensioned = True
End If
Cmt2exArr(UBound(Cmt2exArr)) = C2X
End If
Next


On Error Resume Next
For Each cd In Cmt2exArr
Cmt2ex.Add cd, cd
Next

'Counts number of comments made by authors to exclude
For g = LBound(Cmt2exArr) To UBound(Cmt2exArr)
h = 0
For i = 1 To nCount
With oDoc.Comments(i)
If .Author = Cmt2exArr(g) Then h = h + 1
End With
Next
Next

'Counts number of comments that are included in the tracker
cmTally = nCount - h

cmSummary = "Extracted:" & vbTab & vbTab & vbTab & cmTally & " comments from " & Cmt2ex.Count & " people." & vbNewLine _
& "Total in document:" & vbTab & vbTab & nCount & " comments from" & vbNewLine _
& vbTab & vbTab & vbTab & lAn & " people." & vbNewLine & vbNewLine

End If

ElseIf chsEx = vbNo Then
cmInc = True: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
cmSummary = "All " & nCount & " comments from " & CmtCol(1) & " extracted."
GoTo EndComCount
ElseIf chsEx = vbCancel Then
cmInc = False: cmEx = False
Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"
Cmt2exArr(UBound(Cmt2exArr)) = "ZilchCom 2"
GoTo EndComCount
End If
End If


EndComCount:
End Sub




Public Sub iii_Rev_Analyse()


Dim b, c, e, g, h, i, n As Long
Dim sReviewerTxt1, initRevSum, chsRevEx, stReviewer, sTReviewrs, _
rtrn2Revex, revMax, selRevs, rtrnrvlist, R2X As String
Dim ReviewerArr() As String
Dim RevCol As New Collection, ra


If revSkip = True Then GoTo EndRevCount

sReviewerTxt1 = "The following people have made tracked insertions/deletions:" & vbNewLine & vbNewLine


revInc = False

If rCount = 1 Then
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.NextRevision.Range.Select
With Selection.Range.Revisions(1)
If .Type = wdRevisionDelete Or wdRevisionInsert Then
initRevSum = "There is only one tracked insertion/deletion in this document." & vbNewLine & vbNewLine & "Do you want to include this in the tracker?"
revMax = "There is only one reviewer, so you can't exclude them from the tracker."
lRn = 1
Else
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
MsgBox "There are no tracked insertions/deletions in this document.", vbOKOnly + vbCritical
revInc = False
End
End If
End With
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
ElseIf rCount > 1 Then
'Compiles a list of people who have made changes in the document

MsgBox "Note: Word may appear to freeze at various points. Please be patient." & vbNewLine & vbNewLine & _
"The more tracked changes there are, the longer the freezes will be.", vbOKOnly + vbInformation, "Word is now processing tracked changes"

Application.Screenrefresh
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

indelCount = 0

blDimensioned = False
For b = 1 To rCount
Selection.NextRevision
With Selection.Range.Revisions(1)
If ((.Type = wdRevisionDelete) Or (.Type = wdRevisionInsert)) _
And (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") Then
indelCount = indelCount + 1
stReviewer = .Author
If stReviewer <> "" Then
If blDimensioned = True Then
ReDim Preserve ReviewerArr(0 To UBound(ReviewerArr) + 1) As String
Else
ReDim ReviewerArr(0 To 0) As String
ReviewerArr(0) = ""
blDimensioned = True
End If
ReviewerArr(UBound(ReviewerArr)) = stReviewer
End If
End If
End With
Next

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True

'Collects and counts reviewers
On Error Resume Next
For Each ra In ReviewerArr
RevCol.Add ra, ra
Next

lRn = RevCol.Count

'Reviewer exclusion text building
If RevCol.Count = 1 Then
revMax = "There is only one reviewer, so you can't exclude them from the tracker."
initRevSum = "There are " & indelCount & " tracked insertions/deletions from " & RevCol(1) & "." & vbNewLine & vbNewLine & "Do you want to include tracked changes in the tracker?"
ElseIf RevCol.Count > 1 Then
sTReviewrs = ""
For c = 1 To lRn
sTReviewrs = sTReviewrs & c & ". " & RevCol(c) & vbNewLine
Next

initRevSum = "There are " & indelCount & " tracked insertions/deletions from " & lRn & " people." & vbNewLine & sReviewerTxt1 & sTReviewrs & vbNewLine _
& vbNewLine & "Do you want to include tracked changes in the tracker?"

If RevCol.Count > 2 Then
lFRevn = RevCol.Count - 1
revMax = "You can exclude tracked insertions/deletions from a maximum of " & lFRevn & " people." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
ElseIf RevCol.Count = 2 Then
lFRevn = 1
revMax = "You can exclude tracked insertions/deletions from a maximum of one person." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
End If
End If
End If

'Decide whether to include tracked changes in the tracker
selRevs = MsgBox(initRevSum, vbYesNo + vbQuestion)

If selRevs = vbYes Then
revInc = True
ElseIf selRevs = vbNo Then
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
GoTo EndRevCount
End If

If lRn = 1 Then
If MsgBox(revMax, vbOKCancel + vbInformation) = vbOK Then
revInc = True: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
revSummary = "All " & indelCount & " tracked insertions/deletions from " & RevCol(1) & " extracted."
GoTo EndRevCount
Else
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
GoTo EndRevCount
End If
Else
'Choose whether to exclude any reviewers
chsRevEx = MsgBox(sReviewerTxt1 & sTReviewrs & vbNewLine & revMax, vbYesNoCancel)
If chsRevEx = vbYes Then
revEx = True
nrv2ex:
'Choose number of reviewers to exclude
rev2exN = InputBox(sReviewerTxt1 & sTReviewrs & vbNewLine & "How many people do you want to exclude?" & vbNewLine & vbNewLine & "Maximum of " & lFRevn & ".", "Number to exclude")

'Number validity testing
If (IsNumeric(rev2exN) = False) Or (rev2exN > (RevCol.Count - 1)) Or (rev2exN < 1) Then
rtrn2Revex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2Revex = vbRetry Then
GoTo nrv2ex
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
End If
Else
'Build user-defined list of reviewers to exclude
blDimensioned = False
For e = 1 To rev2exN
Revexlist:
n = InputBox(sReviewerTxt1 & sTReviewrs & vbNewLine & "Enter the number of the person to exclude, exactly " & _
vbNewLine & "as it appears in the list above.")
If (n > RevCol.Count) Or (n = 0) Or (IsNumeric(n) = False) Then
rtrnrvlist = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2Revex = vbRetry Then
GoTo Revexlist
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
End If
Else
R2X = RevCol(n)

If blDimensioned = True Then
ReDim Preserve Rev2exArr(0 To UBound(Rev2exArr) + 1) As String
Else
ReDim Rev2exArr(0 To 0) As String
Rev2exArr(0) = ""
blDimensioned = True
End If
Rev2exArr(UBound(Rev2exArr)) = R2X
End If
Next

On Error Resume Next
For Each rd In Rev2exArr
Review2ex.Add rd, rd
Next


'Counts number of changes made by reviewers to exclude
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory


h = 0
For i = 1 To rCount
With Selection.NextRevision
If .Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*" Then
For g = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(g) Then h = h + 1
Next
End If
End With
Next


crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
Application.Screenrefresh


'Counts number of changes that are included in the tracker
revTally = indelCount - h

revSummary = "Extracted:" & vbTab & vbTab & vbTab & revTally & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & Review2ex.Count & " people." & vbNewLine & "Total in document:" _
& vbTab & vbTab & indelCount & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & lRn & " people." & vbNewLine & vbNewLine

End If

ElseIf chsRevEx = vbNo Then
revInc = True: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
ElseIf chsRevEx = vbCancel Then
revInc = False: revEx = False
Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"
Rev2exArr(UBound(Rev2exArr)) = "ZilchRev 2"
GoTo EndRevCount
End If
End If
EndRevCount:
End Sub




Public Sub iv_Grid_maker()


Dim oNewDoc As Document
Dim oTable As Table
Dim NXTA, NXTR As Boolean
Dim f, i, j, n, rvb, _
blRows, exRows, rve, rvf, rvg, rvr, rparCount, rrcnt As Long
Dim Rvtype, Rvpage, Rvsort, Rvauth As String

Title = "Comment and revision tracker"
Set oDoc = ActiveDocument
rCount = oDoc.Revisions.Count

Application.Screenrefresh

If cmInc = False And revInc = False Then
MsgBox "No comments or revisions selected.", vbOKOnly + vbInformation
GoTo ExitHere
End If


Start:
Application.Screenrefresh
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 cmInc = True And revInc = False Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=nCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Comments extracted from: " & oDoc.Name

ElseIf cmInc = False And revInc = True Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=rCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Revisions extracted from: " & oDoc.Name

ElseIf cmInc = True And revInc = True Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=nCount + rCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Comments and revisions extracted from: " & oDoc.Name

End If
End With


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


Comments:
If cmInc = False Then GoTo Tracks

If cmInc = True Then
f = 1
With oDoc
For n = 1 To nCount
With oDoc
NXTA = False
If cmEx = True Then
For i = LBound(Cmt2exArr) To UBound(Cmt2exArr)
If oDoc.Comments(n).Author = Cmt2exArr(i) Then NXTA = True
Next
End If
End With

If NXTA = False Then

f = f + 1

With oNewDoc
oTable.Rows.Add

With oTable.Rows(f)
.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
End With
End If
NextComB:
Next
End With


End If


Tracks:
If revInc = False Then GoTo Finalise

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

If (cmInc = False) Or (comSkip = True) Then f = 1

With oDoc
Selection.HomeKey Unit:=wdStory
On Error GoTo NextRevb
For rvb = 1 To rCount
With Selection.NextRevision
NXTR = False
If revEx = True Then
For j = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(j) Then NXTR = True
Next
End If

If NXTR = False Then
f = f + 1
If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") _
And (.Type = wdRevisionDelete) Then

Rvtype = "Delete"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"

ElseIf (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") _
And (.Type = wdRevisionInsert) Then

Rvtype = "Insert"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"

Else

Rvtype = ""
Rvpage = ""
Rvauth = ""
Rvsort = ""
Rvtext = ""

End If
End If

End With

If NXTR = False Then
With oNewDoc
oTable.Rows.Add

With oTable.Rows(f)
.Cells(1).Range.Text = Rvsort
.Cells(2).Range.Text = Rvtype
.Cells(4).Range.Text = Rvtext
.Cells(5).Range.Text = Rvauth
.Cells(7).Range.Text = Rvsort

If Rvtype = "Delete" Then
.Cells(2).Range.Font.Color = wdColorRed
.Cells(4).Range.Font.Color = wdColorRed
ElseIf Rvtype = "Insert" = True Then
.Cells(2).Range.Font.Color = wdColorBlue
.Cells(4).Range.Font.Color = wdColorBlue
End If
End With
End With
End If
NextRevb:
oDoc.Activate
Next
End With

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
GoTo Finalise

Finalise:
oNewDoc.Activate
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 cmSummary & revSummary & "Finished creating tracker.", vbOKOnly + vbInformation, "Job summary"



ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set crsRng = Nothing
Set Cmt2ex = Nothing
Set Review2ex = Nothing
Erase Cmt2exArr
Erase Rev2exArr

End Sub

[gmaxey]

I haven't studied you code in detail but a few quick comments. You have a few variables that are not declared:

blDimensioned, Title, Rvtext, myTable noCol

In your public declarations, when you declare thing like this:

Public cmSummary, revSummary, scrllPs As String

You have declarded scrllP as string and everything else as a variant. Do it like this:
Public cmSummary as String, revSummary as String, scrllPs As String

If only have one comment you get a run time error subscript out of range on this line:

Rev2exArr(LBound(Rev2exArr)) = "ZilchRev 1"

If you have one comment and one revision, you get a run time error subscript out of range on this line:

Cmt2exArr(LBound(Cmt2exArr)) = "ZilchCom 1"

[h2whoa]

Thank you for putting in the time to study this code! I was too vigorous in cleaning up all the 'dead' declarations that arose during the evolution of this code, and must have wiped out some needed variables.

That's really good to know about only declaring the last item as the variable type. I was under the misapprehension that it was declaring that whole line as a string! Great to know, and may explain some errors I encountered.

I was so busy testing this code on a document with 122 tracked changes and 147 comments from 8 authors that I never thought to check with a single author. D'oh! I think I know why that is. I haven't setup the Cmt/Rev2exArr's properly. Will take a look now, revise the code and repost.

Your expertise and knowledge is genuinely appreciated. I love learning this stuff, but I only do it through brute force trial and error.

[h2whoa]

Thanks, Greg, for pointing out some of the existing errors. I think I've corrected them. The only thing I do find is that sometimes it will fall over on the Like test or the .Type part of the Grid maker macro. However, if I close and reopen the document I was testing, it then works fine. So I don't really know why it's doing it. But overall, this seems to be doing the job now



'Public declarations
Public blDimensioned As Boolean, cmInc As Boolean, cmEx As Boolean, comSkip As Boolean, revInc As Boolean, revEx As Boolean, revSkip As Boolean
Public cmSummary As String, revSummary As String, scrllPs As String
Public nCount As Long, lAn As Long, lFAn As Long, cmTally As Long, _
rCount As Long, indelCount As Long, lRn As Long, lFRevn As Long, revTally As Long
Public crsRng As Range
Public nc2 As Integer, rev2exN As Integer
Public Cmt2ex As New Collection, cd
Public Review2ex As New Collection, rd
Public Cmt2exArr() As String
Public Rev2exArr() As String
Public oDoc As Document



'Master sub to run the lot
Public Sub Comment_And_InDel_Grid()
i_Reset_Pub_Decs
ii_Com_Analyse
iii_Rev_Analyse
iv_Grid_maker
End Sub



'Sub to ensure all public declarations are reset
Public Sub i_Reset_Pub_Decs()
cmInc = False: cmEx = False: comSkip = False: revInc = False: revEx = False: revSkip = False: blDimensioned = False

cmSummary = "": revSummary = "": scrllPs = ""
nCount = 0: lAn = 0: lFAn = 0: cmTally = 0: rCount = 0: indelCount = 0: lRn = 0: lFRevn = 0: revTally = 0: nc2 = 0: rev2exN = 0

Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing: Set oDoc = Nothing
Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing
Erase Cmt2exArr: Erase Rev2exArr


End Sub



'Sub to gather comment info
Public Sub ii_Com_Analyse()


Dim b As Long, c As Long, e As Long, g As Long, h As Long, i As Long, j As Long
Dim sCmAuTxt1 As String, initCSum As String, chsEx As String, stCmtAuth As String, sTCmAs As String, ComNum As String, _
rtrn2ex As String, rtrn2exsel As String, cmtMax As String, selComs As String, stSkpRv As String, C2X As String
Dim CmtAuArr() As String
Dim CmtCol As New Collection, ca


sCmAuTxt1 = "The following people have made comments:" & vbNewLine & vbNewLine


Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
rCount = ActiveDocument.Revisions.Count
cmInc = False
comSkip = False
Set crsRng = Selection.Range
scrllPs = ActiveWindow.ActivePane.VerticalPercentScrolled

If (nCount = 0) And (rCount > 0) Then
MsgBox "There are no comments in this document.", vbOKOnly + vbCritical
cmInc = False: cmEx = False: comSkip = True
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo Revcheck
ElseIf (nCount = 0) And (rCount = 0) Then
MsgBox "There are no comments or changes in this document in this document.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
ElseIf nCount >= 1 Then
'Compiles a list of people who have made comments in the document
blDimensioned = False
For b = 1 To nCount
stCmtAuth = ActiveDocument.Comments(b).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

'Collects and counts authors
On Error Resume Next
For Each ca In CmtAuArr
CmtCol.Add ca, ca
Next

lAn = CmtCol.Count

'Commenter exclusion text building
If CmtCol.Count = 1 Then
If nCount = 1 Then
ComNum = "There is only one comment from: "
ElseIf nCount > 1 Then
ComNum = "There are " & nCount & " comments from: "
End If
cmtMax = "As there is only one author, you can't exclude them from the tracker."
initCSum = ComNum & CmtCol(1) & "." & vbNewLine & vbNewLine & "Do you want to include comments in the tracker?"
ElseIf CmtCol.Count >= 2 Then
sTCmAs = ""
For c = 1 To lAn
sTCmAs = sTCmAs & c & ". " & CmtCol(c) & vbNewLine
Next

initCSum = "There are " & nCount & " comments from " & lAn & " people." & vbNewLine & sCmAuTxt1 & sTCmAs & vbNewLine _
& vbNewLine & "Do you want to include comments in the tracker?"

If CmtCol.Count > 2 Then
lFAn = CmtCol.Count - 1
cmtMax = "You can exclude comments from a maximum of " & lFAn & " people." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
ElseIf CmtCol.Count = 2 Then
lFAn = 1
cmtMax = "You can exclude comments from a maximum of one person." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
End If
End If
End If

'Decide whether to include comments in the tracker
selComs = MsgBox(initCSum, vbYesNo + vbQuestion)

If selComs = vbYes Then
cmInc = True
ElseIf selComs = vbNo Then
comSkip = True: cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo Revcheck
End If
Revcheck:
If rCount > 0 Then
stSkpRv = MsgBox("Will you want to process tracked changes?", vbYesNo + vbQuestion)
If stSkpRv = vbYes Then
revSkip = False: revInc = True
ElseIf stSkpRv = vbNo Then
revSkip = True
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
End If
If comSkip = True Then GoTo EndComCount
ElseIf rCount = 0 Then
MsgBox "There are no tracked changes in this document. Only comments will be extracted.", vbOKOnly + vbInformation
revSkip = True
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
End If

If lAn = 1 Then
If MsgBox(cmtMax & vbNewLine & vbNewLine & "Press OK to continue" & vbNewLine & vbNewLine & _
"Press Cancel to quit extracting comments", vbOKCancel + vbInformation) = vbOK Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
If nCount = 1 Then
cmSummary = "The comment from " & """" & CmtCol(1) & """" & " has been extracted." & vbNewLine & vbNewLine
ElseIf nCount >= 2 Then
cmSummary = "All " & nCount & " comments from " & """" & CmtCol(1) & """" & " have been extracted." & vbNewLine & vbNewLine
End If
GoTo EndComCount
Else
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount
End If
Else
'Choose whether to exclude any commenters
chsEx = MsgBox("LAN > 1!!" & sCmAuTxt1 & sTCmAs & vbNewLine & cmtMax, vbYesNoCancel)
If chsEx = vbYes Then
cmEx = True
n2ex:
'Choose number of commenters to exclude
nc2 = InputBox(sCmAuTxt1 & sTCmAs & vbNewLine & "How many people do you want to exclude?" & vbNewLine & vbNewLine & "Maximum of " & lFAn & ".", "Number to exclude")

'Number validity testing
If (IsNumeric(nc2) = False) Or (nc2 > (CmtCol.Count - 1)) Or (nc2 = 0) Then
rtrn2ex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2ex = vbRetry Then
GoTo n2ex

ElseIf rtrn2ex = vbAbort Then
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount

ElseIf rtrn2ex = vbIgnore Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "All " & nCount & " comments extracted."
GoTo EndComCount
End If
Else
'Build user-defined list of commenters to exclude
blDimensioned = False
For e = 1 To nc2
Exn:
j = InputBox(sCmAuTxt1 & sTCmAs & vbNewLine & "Enter the number of the person to exclude, from the list above.")
If (j > CmtCol.Count) Or (j = 0) Or (IsNumeric(j) = False) Then
rtrn2exsel = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2exsel = vbRetry Then
GoTo Exn

ElseIf rtrn2exsel = vbAbort Then
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount

ElseIf rtrn2exsel = vbIgnore Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "All " & nCount & " comments extracted."
GoTo EndComCount
End If
Else

C2X = CmtCol(j)


If blDimensioned = True Then
ReDim Preserve Cmt2exArr(0 To UBound(Cmt2exArr) + 1) As String
Else
ReDim Cmt2exArr(0 To 0) As String
Cmt2exArr(0) = ""
blDimensioned = True
End If
Cmt2exArr(UBound(Cmt2exArr)) = C2X
End If
Next


On Error Resume Next
For Each cd In Cmt2exArr
Cmt2ex.Add cd, cd
Next

'Counts number of comments made by authors to exclude
For g = LBound(Cmt2exArr) To UBound(Cmt2exArr)
h = 0
For i = 1 To nCount
With oDoc.Comments(i)
If .Author = Cmt2exArr(g) Then h = h + 1
End With
Next
Next

'Counts number of comments that are included in the tracker
cmTally = nCount - h

cmSummary = "Extracted:" & vbTab & vbTab & vbTab & cmTally & " comments from " & Cmt2ex.Count & " people." & vbNewLine _
& "Total in document:" & vbTab & vbTab & nCount & " comments from" & vbNewLine _
& vbTab & vbTab & vbTab & lAn & " people." & vbNewLine & vbNewLine

End If

ElseIf chsEx = vbNo Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "All " & nCount & " comments from " & CmtCol(1) & " extracted."
GoTo EndComCount
ElseIf chsEx = vbCancel Then
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount
End If
End If


EndComCount:
End Sub



'Sub to gather information about the tracked insertions and deletions

Public Sub iii_Rev_Analyse()


Dim b As Long, c As Long, e As Long, g As Long, h As Long, i As Long, n As Long
Dim sReviewerTxt1 As String, initRevSum As String, chsRevEx As String, stReviewer As String, sTReviewrs As String, _
rtrn2Revex As String, revMax As String, selRevs As String, rtrnrvlist As String, R2X As String, RevNum As String
Dim ReviewerArr() As String
Dim RevCol As New Collection, ra


If revSkip = True Then GoTo EndRevCount

sReviewerTxt1 = "The following people have made tracked insertions/deletions:" & vbNewLine & vbNewLine


revInc = False

If rCount = 1 Then
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.NextRevision.Range.Select
With Selection.Range.Revisions(1)
If .Type = wdRevisionDelete Or wdRevisionInsert Then
indelCount = 1
lRn = 1
revEx = False
stReviewer = .Author
ReDim ReviewerArr(0 To 1) As String
ReviewerArr(0) = ""
ReviewerArr(1) = stReviewer

ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
Else
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
MsgBox "There are no tracked insertions/deletions in this document.", vbOKOnly + vbCritical
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If
End With

ElseIf rCount > 1 Then
'Compiles a list of people who have made changes in the document

MsgBox "Note: Word may appear to freeze at various points. Please be patient." & vbNewLine & vbNewLine & _
"The more tracked changes there are, the longer the freezes will be.", vbOKOnly + vbInformation, "Word is now processing tracked changes"

Application.Screenrefresh
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

indelCount = 0

blDimensioned = False
For b = 1 To rCount
Selection.NextRevision
With Selection.Range.Revisions(1)
If ((.Type = wdRevisionDelete) Or (.Type = wdRevisionInsert)) _
And (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") Then
indelCount = indelCount + 1
stReviewer = .Author
If stReviewer <> "" Then
If blDimensioned = True Then
ReDim Preserve ReviewerArr(0 To UBound(ReviewerArr) + 1) As String
Else
ReDim ReviewerArr(0 To 0) As String
ReviewerArr(0) = ""
blDimensioned = True
End If
ReviewerArr(UBound(ReviewerArr)) = stReviewer
End If
End If
End With
Next
End If

'Collects and counts reviewers
On Error Resume Next
For Each ra In ReviewerArr
RevCol.Add ra, ra
Next

lRn = RevCol.Count

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True

If indelCount = 0 Then
MsgBox "There are no tracked insertions/deletions in this document.", vbOKOnly + vbCritical
revInc = False
GoTo EndRevCount
End If

'Reviewer exclusion text building
If RevCol.Count = 1 Then
If indelCount = 1 Then
RevNum = "There is only one tracked insertion/deletion from: "
ElseIf indelCount > 1 Then
RevNum = "There are " & indelCount & " tracked insertions/deletions from: "
End If
revMax = "There is only one reviewer, so you can't exclude them from the tracker."
initRevSum = RevNum & RevCol(1) & "." & vbNewLine & vbNewLine & "Do you want to include tracked changes in the tracker?"
ElseIf RevCol.Count > 1 Then
sTReviewrs = ""
For c = 1 To lRn
sTReviewrs = sTReviewrs & c & ". " & RevCol(c) & vbNewLine
Next

initRevSum = "There are " & indelCount & " tracked insertions/deletions from " & lRn & " people." & vbNewLine & sReviewerTxt1 & sTReviewrs & vbNewLine _
& vbNewLine & "Do you want to include tracked changes in the tracker?"

If RevCol.Count > 2 Then
lFRevn = RevCol.Count - 1
revMax = "You can exclude tracked insertions/deletions from a maximum of " & lFRevn & " people." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
ElseIf RevCol.Count = 2 Then
lFRevn = 1
revMax = "You can exclude tracked insertions/deletions from a maximum of one person." & vbNewLine & vbNewLine & "Do you want to exclude anyone?"
End If
End If

'Decide whether to include tracked changes in the tracker
selRevs = MsgBox(initRevSum, vbYesNo + vbQuestion)

If selRevs = vbYes Then
revInc = True
ElseIf selRevs = vbNo Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If

If lRn = 1 Then
If MsgBox(revMax, vbOKCancel + vbInformation) = vbOK Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
If indelCount = 1 Then
revSummary = "The tracked insertions/deletion from " & """" & RevCol(1) & """" & " has been extracted." & vbNewLine & vbNewLine
ElseIf indelCount >= 2 Then
revSummary = "All " & indelCount & " tracked insertions/deletions from " & """" & RevCol(1) & """" & " have been extracted." & vbNewLine & vbNewLine
End If
GoTo EndRevCount
Else
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If
Else
'Choose whether to exclude any reviewers
chsRevEx = MsgBox(sReviewerTxt1 & sTReviewrs & vbNewLine & revMax, vbYesNoCancel)
If chsRevEx = vbYes Then
revEx = True
nrv2ex:
'Choose number of reviewers to exclude
rev2exN = InputBox(sReviewerTxt1 & sTReviewrs & vbNewLine & "How many people do you want to exclude?" & vbNewLine & vbNewLine & "Maximum of " & lFRevn & ".", "Number to exclude")

'Number validity testing
If (IsNumeric(rev2exN) = False) Or (rev2exN > (RevCol.Count - 1)) Or (rev2exN < 1) Then
rtrn2Revex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2Revex = vbRetry Then
GoTo nrv2ex
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
End If
Else
'Build user-defined list of reviewers to exclude
blDimensioned = False
For e = 1 To rev2exN
Revexlist:
n = InputBox(sReviewerTxt1 & sTReviewrs & vbNewLine & "Enter the number of the person to exclude, exactly " & _
vbNewLine & "as it appears in the list above.")
If (n > RevCol.Count) Or (n = 0) Or (IsNumeric(n) = False) Then
rtrnrvlist = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2Revex = vbRetry Then
GoTo Revexlist
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
End If
Else
R2X = RevCol(n)

If blDimensioned = True Then
ReDim Preserve Rev2exArr(0 To UBound(Rev2exArr) + 1) As String
Else
ReDim Rev2exArr(0 To 0) As String
Rev2exArr(0) = ""
blDimensioned = True
End If
Rev2exArr(UBound(Rev2exArr)) = R2X
End If
Next

On Error Resume Next
For Each rd In Rev2exArr
Review2ex.Add rd, rd
Next


'Counts number of changes made by reviewers to exclude
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory


h = 0
For i = 1 To rCount
With Selection.NextRevision
If .Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*" Then
For g = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(g) Then h = h + 1
Next
End If
End With
Next


crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
Application.Screenrefresh


'Counts number of changes that are included in the tracker
revTally = indelCount - h

revSummary = "Extracted:" & vbTab & vbTab & vbTab & revTally & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & Review2ex.Count & " people." & vbNewLine & "Total in document:" _
& vbTab & vbTab & indelCount & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & lRn & " people." & vbNewLine & vbNewLine

End If

ElseIf chsRevEx = vbNo Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted."
GoTo EndRevCount
ElseIf chsRevEx = vbCancel Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If
End If
EndRevCount:
End Sub



'Final sub to collect everything together and put it into the grid

Public Sub iv_Grid_maker()


Dim oNewDoc As Document
Dim oTable As Table, oTracker As Table
Dim NXTA As Boolean, NXTR As Boolean
Dim f As Long, i As Long, j As Long, n As Long, z As Long, blRows As Long
Dim Rvtype As String, Rvpage As String, Rvsort As String, Rvauth As String, Rvtext As String

Set oDoc = ActiveDocument
rCount = oDoc.Revisions.Count

Application.Screenrefresh

If cmInc = False And revInc = False Then
MsgBox "No comments or revisions selected.", vbOKOnly + vbInformation
GoTo ExitHere
End If


Start:
Application.Screenrefresh
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 cmInc = True And revInc = False Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=nCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Comments extracted from: " & oDoc.Name

ElseIf cmInc = False And revInc = True Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=rCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Revisions extracted from: " & oDoc.Name

ElseIf cmInc = True And revInc = True Then
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numRows:=nCount + rCount + 1, _
NumColumns:=7)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Comments and revisions extracted from: " & oDoc.Name

End If
End With


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


Comments:
If cmInc = False Then GoTo Tracks

If cmInc = True Then
f = 1
With oDoc
For n = 1 To nCount
With oDoc
NXTA = False
If cmEx = True Then
For i = LBound(Cmt2exArr) To UBound(Cmt2exArr)
If oDoc.Comments(n).Author = Cmt2exArr(i) Then NXTA = True
Next
End If
End With

If NXTA = False Then

f = f + 1

With oNewDoc
oTable.Rows.Add

With oTable.Rows(f)
.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
End With
End If
NextComB:
Next
End With


End If


Tracks:
If revInc = False Then GoTo Finalise

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

If (cmInc = False) Or (comSkip = True) Then f = 1

With oDoc
Selection.HomeKey Unit:=wdStory
On Error GoTo NextRevb
For z = 0 To rCount
With oDoc
With Selection.NextRevision
NXTR = False
If revEx = True Then
For j = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(j) Then NXTR = True
Next
End If

If NXTR = False Then
f = f + 1
If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") _
And (.Type = wdRevisionDelete) Then

Rvtype = "Delete"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"

ElseIf (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") _
And (.Type = wdRevisionInsert) Then

Rvtype = "Insert"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"

Else

Rvtype = ""
Rvpage = ""
Rvauth = ""
Rvsort = ""
Rvtext = ""

End If
End If

End With
End With

If NXTR = False Then
With oNewDoc
oTable.Rows.Add

With oTable.Rows(f)
.Cells(1).Range.Text = Rvpage
.Cells(2).Range.Text = Rvtype
.Cells(4).Range.Text = Rvtext
.Cells(5).Range.Text = Rvauth
.Cells(7).Range.Text = Rvsort

If Rvtype = "Delete" Then
.Cells(2).Range.Font.Color = wdColorRed
.Cells(4).Range.Font.Color = wdColorRed
ElseIf Rvtype = "Insert" = True Then
.Cells(2).Range.Font.Color = wdColorBlue
.Cells(4).Range.Font.Color = wdColorBlue
End If
End With
End With
End If
NextRevb:
oDoc.Activate
Next
End With

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
GoTo Finalise

Finalise:
oNewDoc.Activate
Set oTracker = ActiveDocument.Tables(1)
With oTracker.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With

oTracker.Select

With 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"



.Columns(7).Delete
End With


With oTracker
For blRows = .Rows.Count To 1 Step -1
With .Rows(blRows)
If (.Cells(1).Range.Text = "" & Chr(13) & Chr(7)) And (.Cells(2).Range.Text = "" & Chr(13) & Chr(7)) And (.Cells(3).Range.Text = "" & Chr(13) & Chr(7)) _
And (.Cells(4).Range.Text = "" & Chr(13) & Chr(7)) And (.Cells(5).Range.Text = "" & Chr(13) & Chr(7)) _
And (.Cells(6).Range.Text = "" & Chr(13) & Chr(7)) Then .Delete
End With
Next blRows
End With



Application.ScreenUpdating = True
Application.Screenrefresh

oNewDoc.Activate
MsgBox cmSummary & revSummary & "Finished creating tracker.", vbOKOnly + vbInformation, "Job summary"



ExitHere:


cmInc = False: cmEx = False: comSkip = False: revInc = False: revEx = False: revSkip = False: blDimensioned = False

cmSummary = "": revSummary = "": scrllPs = ""
nCount = 0: lAn = 0: lFAn = 0: cmTally = 0: rCount = 0: indelCount = 0: lRn = 0: lFRevn = 0: revTally = 0: nc2 = 0: rev2exN = 0

Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing: Set oDoc = Nothing
Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing
Erase Cmt2exArr: Erase Rev2exArr

Set oNewDoc = Nothing: Set oTable = Nothing: Set oTracker = Nothing

End Sub

[gmaxey]

OK, I ran your revised code with one comment, one insertion and one deletion.

I think that there were no fewer than seven message boxes that popped up in the process. Your user's might find that annoying.

The code error'd on this line: If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") _

You have not commented you code very well so I'm not sure what you are trying to do exactly but I did revise your final macro a bit and it runs without error:


Public Sub iv_Grid_maker()
Dim oNewDoc As Document
Dim oTbl As Table
Dim NXTA As Boolean, NXTR As Boolean
Dim lngIndex As Long
Dim oRev As Revision
Dim lngRow As Long, i As Long, j As Long
Dim Rvtype As String, Rvpage As String, Rvsort As String, Rvauth As String, Rvtext As String

Set oDoc = ActiveDocument
lngRevisions = oDoc.Revisions.Count
If cmInc = False And revInc = False Then
MsgBox "No comments or revisions selected.", vbOKOnly + vbInformation
GoTo lbl_Exit
End If
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
With oNewDoc
.PageSetup.Orientation = wdOrientLandscape
Select Case True
Case cmInc And revInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Comments and revisions extracted from: " & oDoc.Name
Case cmInc And Not revInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Comments extracted from: " & oDoc.Name
Case revInc And Not cmInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Revisions extracted from: " & oDoc.Name
End Select
With .Styles(wdStyleNormal)
.Font.Name = "Calibri"
.Font.Size = 9
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
Set oTbl = .Tables.Add(Selection.Range, lngComments + lngRevisions + 1, 7)
With oTbl
.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
With .Rows(1)
.HeadingFormat = True
.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
End With
If cmInc = True Then
lngRow = 1
For lngIndex = 1 To lngComments
NXTA = False
If cmEx = True Then
For i = LBound(Cmt2exArr) To UBound(Cmt2exArr)
If .Comments(lngIndex).Author = Cmt2exArr(i) Then NXTA = True
Next
End If
If NXTA = False Then
lngRow = lngRow + 1
oTbl.Rows.Add
With oTbl.Rows(lngRow)
.Cells(1).Range.Text = oDoc.Comments(lngIndex).Scope.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = "Comment"
.Cells(3).Range.Text = oDoc.Comments(lngIndex).Range.Text
.Cells(4).Range.Text = oDoc.Comments(lngIndex).Scope
.Cells(5).Range.Text = oDoc.Comments(lngIndex).Author
.Cells(7).Range.Text = oDoc.Comments(lngIndex).Scope.Information(wdFirstCharacterLineNumber)
End With
End If
Next
End If
If revInc Then
If (cmInc = False) Or (comSkip = True) Then lngRow = 1
On Error GoTo NextRevb
For lngIndex = 1 To lngRevisions
Set oRev = oDoc.Revisions(lngIndex)
With oRev
NXTR = False
If revEx = True Then
For j = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(j) Then NXTR = True
Next
End If
If NXTR = False Then
lngRow = lngRow + 1
If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") And (.Type = wdRevisionDelete) Then
Rvtype = "Delete"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"
ElseIf (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") And (.Type = wdRevisionInsert) Then
Rvtype = "Insert"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"
Else
Rvtype = ""
Rvpage = ""
Rvauth = ""
Rvsort = ""
Rvtext = ""
End If
End If
End With
If NXTR = False Then
oTbl.Rows.Add
With oTbl.Rows(lngRow)
.Cells(1).Range.Text = Rvpage
.Cells(2).Range.Text = Rvtype
.Cells(4).Range.Text = Rvtext
.Cells(5).Range.Text = Rvauth
.Cells(7).Range.Text = Rvsort
If Rvtype = "Delete" Then
.Cells(2).Range.Font.Color = wdColorRed
.Cells(4).Range.Font.Color = wdColorRed
ElseIf Rvtype = "Insert" = True Then
.Cells(2).Range.Font.Color = wdColorBlue
.Cells(4).Range.Font.Color = wdColorBlue
End If
End With
End If
NextRevb:
Next
End If
End With
oDoc.Activate
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Finalise:
oNewDoc.Activate
With oTbl.Borders ' Tracker.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
oTbl.Select
With 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"
.Columns(7).Delete
End With
With oTbl
For lngIndex = .Rows.Count To 1 Step -1
If Len(.Rows(lngIndex).Range.Text) = 14 Then .Rows(lngIndex).Delete
Next lngIndex
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox cmSummary & revSummary & "Finished creating tracker.", vbOKOnly + vbInformation, "Job summary"
lbl_Exit:
Set oNewDoc = Nothing: Set oTbl = Nothing: Set oRev = Nothing
End Sub



We each develop our own styles. I find it easier when my variables have meaningful names e.g., lngComments vs nCount.

[h2whoa]

This is brilliant, thank you, Greg.

Basically, the If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") test was my clumsy way to smooth over some weird runtime errors I was getting when the code tried to read .Author and .Type properties. The errors were unpredictable so I wondered if they were caused by tracked changes in non-text ranges (i.e. pictures). So I added that to make sure only alphanumeric ranges were included. I'm not entirely sure it's necessary, but was an idea when I was at my wits' end.

[Kilroy]

I added the new IV portion and now the comments are not populating the table.

[h2whoa]

I added the new IV portion and now the comments are not populating the table.

Yes, there was an undeclared variable. I have actually just finished updating it. The whole macro now runs with fewer message boxes. I think the the below code should work now!



'Public declarations for variables used throughout


Public blDimensioned As Boolean, cmInc As Boolean, cmEx As Boolean, comSkip As Boolean, revInc As Boolean, revEx As Boolean, revSkip As Boolean
Public cmSummary As String, revSummary As String, scrllPs As String
Public lngComments As Long, lAn As Long, lFAn As Long, cmTally As Long, _
lngRevisions As Long, indelCount As Long, lRn As Long, lFRevn As Long, revTally As Long
Public crsRng As Range
Public nc2 As Integer, rev2exN As Integer
Public Cmt2ex As New Collection, cd
Public Review2ex As New Collection, rd
Public Cmt2exArr() As String
Public Rev2exArr() As String
Public oDoc As Document
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'Gathers information on the comments




Public Sub Comment_And_InDel_Grid()
If MsgBox("1." & vbTab & "Word may appear to freeze at multiple points" & vbNewLine & vbTab & "during this process." & vbNewLine & vbNewLine & _
"2." & vbTab & "This is normal as this process is memory-intesive." & vbNewLine & vbTab & "Word has not crashed!" & vbNewLine & vbNewLine & _
"3." & vbTab & "The more revisions and comments there are, the longer" & vbNewLine & vbTab & "the process will take. Just wait for the " & _
"process to finish." & vbNewLine & vbNewLine & "4." & vbTab & "You will be asked to make choices at a couple of points" _
& vbTab & vbTab & "in this process.", vbOKCancel + vbInformation, "Important notes") = vbCancel Then End


i_Reset_Pub_Decs
ii_Com_Analyse
iii_Rev_Analyse
iv_Grid_maker
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'Resets the public declarations




Public Sub i_Reset_Pub_Decs()
cmInc = False: cmEx = False: comSkip = False: revInc = False: revEx = False: revSkip = False: blDimensioned = False

cmSummary = "": revSummary = "": scrllPs = ""
lngComments = 0: lAn = 0: lFAn = 0: cmTally = 0: lngRevisions = 0: indelCount = 0: lRn = 0: lFRevn = 0: revTally = 0: nc2 = 0: rev2exN = 0

Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing: Set oDoc = Nothing
Set crsRng = Nothing: Set Cmt2ex = Nothing: Set Review2ex = Nothing
Erase Cmt2exArr: Erase Rev2exArr


End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'Gathers information on the comments




Public Sub ii_Com_Analyse()


Dim lngIndex As Long, lngIndexA As Long, lngAuthExNum As Long, lngCombSel As Long, lngInDeIndex As Long, lngComAusExt As Long
Dim sCmAuTxt1 As String, initCSum As String, stCmtAuth As String, sTCmAs As String, ComNum As String, _
rtrn2ex As String, rtrn2exsel As String, cmtMax As String, selComs As String, C2X As String, strComExList As String, _
singleComSum As String, strPerPeop As String
Dim CmtAuArr() As String
Dim SingComBool As Boolean
Dim CmtCol As New Collection, ca


SingComBool = False
sCmAuTxt1 = "The following people have made comments:" & vbNewLine & vbNewLine


Set oDoc = ActiveDocument
lngComments = ActiveDocument.Comments.Count
lngRevisions = ActiveDocument.Revisions.Count
cmInc = False
comSkip = False
Set crsRng = Selection.Range
scrllPs = ActiveWindow.ActivePane.VerticalPercentScrolled


Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

indelCount = 0 'indelCount counts the number of tracked insertions and deletions

For lngInDeIndex = 1 To lngRevisions
Selection.NextRevision
With Selection.Range.Revisions(1)
'The like test has been added here (and throughout) to prevent errors when tracked changes are not in text ranges
If ((.Type = wdRevisionDelete) Or (.Type = wdRevisionInsert)) _
And (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") Then indelCount = indelCount + 1
End With
Next

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
Application.Screenrefresh


'This section handles the initial options, based on number of comments/revisions
If (lngComments = 0) And (indelCount > 0) Then
If MsgBox("There are no comments in this document but there are " & indelCount & " tracked insertions/deletions." & vbNewLine & vbNewLine _
& "Do you want to proceed with extracting tracked changes?", vbYesNo + vbInformation) = vbYes Then

cmInc = False: cmEx = False: comSkip = True
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"

revSkip = False: revInc = True
GoTo EndComCount
Else
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
End If
ElseIf (lngComments = 0) And (lngRevisions = 0) Then
MsgBox "There are no comments or tracked insertions/deletions in this document." & vbNewLine & vbNewLine _
& "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
ElseIf lngComments >= 1 Then
'Compiles a list of people who have made comments in the document
blDimensioned = False
For lngIndex = 1 To lngComments
stCmtAuth = ActiveDocument.Comments(lngIndex).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
End If

'Collects and counts authors
On Error Resume Next
For Each ca In CmtAuArr
CmtCol.Add ca, ca
Next

lAn = CmtCol.Count

'Limits choices if there are only comments from 1 person
If CmtCol.Count = 1 Then
SingComBool = True
If indelCount = 0 Then
If lngComments = 1 Then
ComNum = "There are no tracked insertions/deletions and" & vbNewLine & _
"there is only one comment from: " & CmtCol(1) & vbNewLine & vbNewLine & _
"Do you you still want to extract their comment?"

singleComSum = "The comment from " & """" & CmtCol(1) & """" & " has been extracted." & vbNewLine & vbNewLine
ElseIf lngComments >= 2 Then ComNum = "There are no tracked insertions/deletions but" & vbNewLine & _
"there are " & lngComments & " comments from: " & CmtCol(1) & vbNewLine & vbNewLine & _
"Do you you still want to extract their comments?"
singleComSum = "All " & lngComments & " comments from " & """" & CmtCol(1) & """" & " have been extracted." & vbNewLine & vbNewLine
End If

revSkip = True: revInc = False 'Choose whether to include comments from single author
If MsgBox(ComNum, vbYesNo + vbQuestion) = vbYes Then
cmInc = True: cmEx = False: comSkip = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "COMMENTS:" & vbNewLine & singleComSum & vbNewLine
GoTo EndComCount
Else
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
End If

ElseIf indelCount >= 1 Then
If lngComments = 1 Then
initCSum = "There is only one comment from: " & CmtCol(1) & vbNewLine & vbNewLine
GoTo CombiSelect
ElseIf lngComments >= 2 Then
initCSum = "There are " & lngComments & " comments from: " & CmtCol(1) & vbNewLine & vbNewLine
GoTo CombiSelect
End If
End If
'Options for more than one commenter
ElseIf CmtCol.Count >= 2 Then
SingComBool = False
sTCmAs = ""
For lngIndex = 1 To lAn
sTCmAs = sTCmAs & lngIndex & ". " & CmtCol(lngIndex) & vbNewLine
Next

strComExList = "0. To exclude nobody" & vbNewLine & sTCmAs

initCSum = "There are " & lngComments & " comments from " & lAn & " people." & vbNewLine & sCmAuTxt1 & sTCmAs & vbNewLine

If CmtCol.Count > 2 Then
lFAn = CmtCol.Count - 1
cmtMax = "You can exclude comments from a maximum of " & lFAn & " people." & vbNewLine & vbNewLine
ElseIf CmtCol.Count = 2 Then
lFAn = 1
cmtMax = "You can exclude comments from a maximum of one person." & vbNewLine & vbNewLine
End If

If indelCount = 0 Then
selComs = MsgBox("There are no insertions/deletions in this document." & vbNewLine & vbNewLine & _
initCSum & "Do you want to continue with just extracting comments?", vbYesNo + vbQuestion)
If selComs = vbYes Then
cmInc = True: revSkip = True: revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo n2ex
ElseIf selComs = vbNo Then
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
End If
ElseIf indelCount >= 1 Then
GoTo CombiSelect
End If
End If

'This section is to choose whether to extract just comments, revisions or both
CombiSelect:
lngCombSel = InputBox(initCSum & "There are also " & indelCount & " tracked insertions/deletions that could be extracted." _
& vbNewLine & vbNewLine & "In the box below, type a number corresponding to your choice." _
& vbNewLine & vbNewLine & "1: " & "To ONLY extract comments." & vbNewLine & _
"2: " & "To ONLY extract revisions." & vbNewLine & "3: " & "To extract comments and revisions." & vbNewLine & _
"4: " & "To cancel and exit.")
If (IsNumeric(lngCombSel) = False) Or (lngCombSel < 1) Or (lngCombSel > 4) Then
MsgBox "Invalid option selected. Please try again.", vbOKOnly + vbCritical
GoTo CombiSelect
ElseIf lngCombSel = 1 Then
cmInc = True: comSkip = False: revSkip = True: revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
ElseIf lngCombSel = 2 Then
cmInc = False: cmEx = False: comSkip = True
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
revSkip = False: revInc = True
cmSummary = ""
GoTo EndComCount
ElseIf lngCombSel = 3 Then
cmInc = True: comSkip = False: revInc = True: revSkip = False
ElseIf lngCombSel = 4 Then
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
End If

If SingComBool = True Then
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
If lngComments = 1 Then
cmSummary = "COMMENTS:" & vbNewLine & "The comment from " & """" & CmtCol(1) & """" & _
" has been extracted." & vbNewLine & vbNewLine & vbNewLine
ElseIf lngComments >= 2 Then
cmSummary = "COMMENTS:" & vbNewLine & "All " & lngComments & " comments from " & """" & CmtCol(1) & """" & _
" have been extracted." & vbNewLine & vbNewLine & vbNewLine
End If
GoTo EndComCount


ElseIf SingComBool = False Then
n2ex:
'Choose number of commenters to exclude
nc2 = InputBox(sCmAuTxt1 & strComExList & vbNewLine & "How many people do you want to exclude?" & vbNewLine & vbNewLine & _
"Maximum of " & lFAn & ".", "Number to exclude")

'Number validity testing
If (IsNumeric(nc2) = False) Or (nc2 > (CmtCol.Count - 1)) Then
rtrn2ex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2ex = vbRetry Then
GoTo n2ex

ElseIf rtrn2ex = vbAbort Then
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount

ElseIf rtrn2ex = vbIgnore Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "COMMENTS:" & vbNewLine & "All " & lngComments & " comments extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndComCount
End If
ElseIf nc2 = 0 Then
cmInc = True: cmEx = False: comSkip = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "COMMENTS:" & vbNewLine & "All " & lngComments & " comments from " & CmtCol(1) & " extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndComCount
ElseIf (nc2 >= 1) And (nc2 <= (CmtCol.Count - 1)) Then
cmInc = True: cmEx = True: comSkip = False
'Build user-defined list of commenters to exclude
blDimensioned = False
For lngIndex = 1 To nc2

'This section builds and populates an array of commenters to exclude
Exn:
lngAuthExNum = InputBox(sCmAuTxt1 & sTCmAs & vbNewLine & "Enter the number of the person to exclude, from the list above.")
If (lngAuthExNum > CmtCol.Count) Or (lngAuthExNum = 0) Or (IsNumeric(lngAuthExNum) = False) Then
rtrn2exsel = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract comments" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2exsel = vbRetry Then
GoTo Exn

ElseIf rtrn2exsel = vbAbort Then
cmInc = False: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
GoTo EndComCount

ElseIf rtrn2exsel = vbIgnore Then
cmInc = True: cmEx = False
ReDim Cmt2exArr(0 To 1) As String
Cmt2exArr(0) = ""
Cmt2exArr(1) = "ZilchCom"
cmSummary = "COMMENTS:" & vbNewLine & "All " & lngComments & " comments extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndComCount
End If
Else
C2X = CmtCol(lngAuthExNum)
If blDimensioned = True Then
ReDim Preserve Cmt2exArr(0 To UBound(Cmt2exArr) + 1) As String
Else
ReDim Cmt2exArr(0 To 0) As String
Cmt2exArr(0) = ""
blDimensioned = True
End If
Cmt2exArr(UBound(Cmt2exArr)) = C2X
End If
Next

On Error Resume Next
For Each cd In Cmt2exArr
Cmt2ex.Add cd, cd
Next

'Counts number of comments made by authors to exclude
cmTally = 0
For lngIndexA = 1 To lngComments
With oDoc.Comments(lngIndexA)
For lngIndex = LBound(Cmt2exArr) To UBound(Cmt2exArr)
If .Author = Cmt2exArr(lngIndex) Then cmTally = cmTally + 1
Next
End With
Next

'Counts number of comments that are included in the tracker
cmTally = lngComments - cmTally

lngComAusExt = (CmtCol.Count - Cmt2ex.Count)

If lngComAusExt = 1 Then
strPerPeop = "1 person."
ElseIf lngComAusExt >= 2 Then
strPerPeop = lngComAusExt & " people."
End If

'Text to be displayed at the end
cmSummary = "COMMENTS:" & vbNewLine & "Extracted:" & vbTab & vbTab & vbTab & cmTally & " comments from " & strPerPeop _
& vbNewLine & vbNewLine & "Total in document:" & vbTab & vbTab & lngComments & " comments from" & vbNewLine _
& vbTab & vbTab & vbTab & lAn & " people." & vbNewLine & vbNewLine & vbNewLine
End If
End If
EndComCount:
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'Gathers information on the tracked revisions


Public Sub iii_Rev_Analyse()


Dim lngIndex As Long, lngIndexA As Long, lngRevExNum As Long, lngSingRev As Long, lngRevAusExt As Long
Dim stReviewer As String, sTReviewrs As String, strRevPerPeop As String, _
rtrn2Revex As String, revMax As String, selRevs As String, rtrnrvlist As String, R2X As String, RevNum As String, strRevExList As String
Dim ReviewerArr() As String
Dim SingRevBool As Boolean
Dim RevCol As New Collection, ra


If revSkip = True Then GoTo EndRevCount
If indelCount = 0 Then
MsgBox "There are no tracked insertions/deletions in this document.", vbOKOnly + vbCritical
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If


revInc = False
SingRevBool = False

'Action if there's only one revision
If lngRevisions = 1 Then
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.NextRevision.Range.Select
With Selection.Range.Revisions(1)
If .Type = wdRevisionDelete Or wdRevisionInsert Then
lRn = 1
revEx = False
stReviewer = .Author
ReDim ReviewerArr(0 To 1) As String
ReviewerArr(0) = ""
ReviewerArr(1) = stReviewer

ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
Else
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
MsgBox "There are no tracked insertions/deletions in this document.", vbOKOnly + vbCritical
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
End If
End With

'Options if there are multiple revisions
ElseIf lngRevisions > 1 Then

MsgBox "Note: Word may appear to freeze at various points. Please be patient." & vbNewLine & vbNewLine & _
"The more tracked changes there are, the longer the freezes will be.", vbOKOnly + vbInformation, "Word is now processing tracked changes"

Application.Screenrefresh
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

'Builds list of reviewers
blDimensioned = False
For lngIndex = 1 To lngRevisions
Selection.NextRevision
With Selection.Range.Revisions(1)
If ((.Type = wdRevisionDelete) Or (.Type = wdRevisionInsert)) _
And (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") Then
stReviewer = .Author
If stReviewer <> "" Then
If blDimensioned = True Then
ReDim Preserve ReviewerArr(0 To UBound(ReviewerArr) + 1) As String
Else
ReDim ReviewerArr(0 To 0) As String
ReviewerArr(0) = ""
blDimensioned = True
End If
ReviewerArr(UBound(ReviewerArr)) = stReviewer
End If
End If
End With
Next
End If

'Collects and counts reviewers
On Error Resume Next
For Each ra In ReviewerArr
RevCol.Add ra, ra
Next

lRn = RevCol.Count

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True

'Limits options if there is only 1 reviewer
If RevCol.Count = 1 Then
If indelCount = 1 Then
RevNum = "There is only one tracked insertion/deletion from: " & RevCol(1) & _
"." & vbNewLine & vbNewLine & "Do you want to extract their tracked change?"
ElseIf indelCount > 1 Then
RevNum = "There are " & indelCount & " tracked insertions/deletions from: " & RevCol(1) & _
"." & vbNewLine & vbNewLine & "Do you want to extract their tracked changes?"
End If
If MsgBox(RevNum, vbYesNo + vbQuestion) = vbYes Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
If indelCount = 1 Then
revSummary = "REVISIONS:" & vbNewLine & "The tracked insertions/deletion from " & """" & RevCol(1) & """" & " has been extracted." & vbNewLine & vbNewLine & vbNewLine
ElseIf indelCount >= 2 Then
revSummary = "REVISIONS:" & vbNewLine & "All " & indelCount & " tracked insertions/deletions from " & """" & RevCol(1) & """" & " have been extracted." & vbNewLine & vbNewLine & vbNewLine
End If
GoTo EndRevCount
Else
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = ""
GoTo EndRevCount
End If

'Options if there are multiple reviewers
ElseIf RevCol.Count > 1 Then
strRevExList = ""
sTReviewrs = "To exclude nobody, type 0" & vbNewLine & _
"To cancel extracting revisions, type " & (lRn + 1) & vbNewLine & _
"To cancel and exit, type " & (lRn + 2) & vbNewLine & vbNewLine & _
"The following people have made comments:" & vbNewLine & vbNewLine
For lngIndex = 1 To lRn
sTReviewrs = sTReviewrs & lngIndex & ". " & RevCol(lngIndex) & vbNewLine
strRevExList = strRevExList & lngIndex & ". To exclude: " & RevCol(lngIndex) & vbNewLine
Next

sTReviewrs = sTReviewrs & vbNewLine

If RevCol.Count > 2 Then
lFRevn = RevCol.Count - 1
revMax = "You can exclude tracked insertions/deletions from a maximum of " & lFRevn & " people." _
& vbNewLine & vbNewLine & "How many people do you want to exclude?"
ElseIf RevCol.Count = 2 Then
SingRevBool = True
lFRevn = 1
revMax = "You can exclude tracked insertions/deletions from a maximum of one person."
End If
End If

'Decide whether to include tracked changes in the tracker


'Actions to take if a maximum of 1 person can be excluded
SingleReview:
If SingRevBool = True Then
lngSingRev = InputBox(revMax & vbNewLine & vbNewLine & strRevExList)
If (IsNumeric(lngSingRev) = False) Or (lngSingRev > (lRn + 2)) Then
MsgBox "Invalid option selected. Please try again.", vbOKOnly + vbCritical
GoTo SingleReview
ElseIf lngSingRev = 0 Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "REVISIONS:" & vbNewLine & "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndRevCount
ElseIf (lngSingRev = 1) Or (lngSingRev = 2) Then
R2X = RevCol(lngSingRev)
revInc = True: revEx = True
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = R2X
ElseIf lngSingRev = 3 Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = ""
GoTo EndRevCount
ElseIf lngSingRev = 4 Then
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
End If
End If



'This section gives options for the number of people to exclude (if any)
If SingRevBool = False Then
nrv2ex:
'Choose number of reviewers to exclude
rev2exN = InputBox(sTReviewrs & vbNewLine & vbNewLine & _
revMax, "Number to exclude")

'Number validity testing
If (IsNumeric(rev2exN) = False) Or (rev2exN = lRn) Or (rev2exN > (lRn + 2)) Then
rtrn2Revex = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)
If rtrn2Revex = vbRetry Then
GoTo nrv2ex
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "REVISIONS:" & vbNewLine & "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndRevCount
End If
ElseIf rev2exN = (lRn + 1) Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = ""
GoTo EndRevCount
ElseIf rev2exN = (lRn + 2) Then
MsgBox "Process terminated.", vbOKOnly + vbCritical
Set oDoc = Nothing
End
ElseIf rev2exN = 0 Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "REVISIONS:" & vbNewLine & "All " & indelCount & " insertions/deletions from all " & lRn & " people extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndRevCount
ElseIf (rev2exN >= 1) And (rev2exN <= lFRevn) Then

'Build user-defined list of reviewers to exclude
revInc = True: revEx = True
blDimensioned = False
For lngIndex = 1 To rev2exN


Revexlist:
lngRevExNum = InputBox("Enter the list number of the person to exclude:" & _
vbNewLine & vbNewLine & strRevExList)
If (lngRevExNum > RevCol.Count) Or (lngRevExNum = 0) Or (IsNumeric(lngRevExNum) = False) Then
rtrnrvlist = MsgBox("Invalid value." & vbNewLine & vbNewLine & "ABORT to not extract revisions" _
& vbNewLine & vbNewLine & "RETRY to enter valid value" _
& vbNewLine & vbNewLine & "IGNORE to proceed without excluding anyone.", vbAbortRetryIgnore + vbCritical)

If rtrn2Revex = vbRetry Then
GoTo Revexlist
ElseIf rtrn2Revex = vbAbort Then
revInc = False: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
GoTo EndRevCount
ElseIf rtrn2Revex = vbIgnore Then
revInc = True: revEx = False
ReDim Rev2exArr(0 To 1) As String
Rev2exArr(0) = ""
Rev2exArr(1) = "ZilchRev"
revSummary = "REVISIONS:" & vbNewLine & "All " & indelCount & " insertions/deletions from all " & lRn & _
" people extracted." & vbNewLine & vbNewLine & vbNewLine
GoTo EndRevCount
End If
Else
R2X = RevCol(lngRevExNum)

If blDimensioned = True Then
ReDim Preserve Rev2exArr(0 To UBound(Rev2exArr) + 1) As String
Else
ReDim Rev2exArr(0 To 0) As String
Rev2exArr(0) = ""
blDimensioned = True
End If
Rev2exArr(UBound(Rev2exArr)) = R2X
End If
Next
End If
End If

On Error Resume Next
For Each rd In Rev2exArr
Review2ex.Add rd, rd
Next



Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory

'Counts number of changes made by reviewers to exclude
revTally = 0
For lngIndex = 1 To lngRevisions
With Selection.NextRevision
If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") And ((.Type = wdRevisionDelete) Or (.Type = wdRevisionInsert)) Then
For lngIndexA = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(lngIndexA) Then revTally = revTally + 1
Next
End If
End With
Next

'Counts number of changes that are included in the tracker
revTally = indelCount - revTally

lngRevAusExt = (RevCol.Count - Review2ex.Count)

If lngRevAusExt = 1 Then
strRevPerPeop = "1 person."
ElseIf lngRevAusExt >= 2 Then
strRevPerPeop = lngRevAusExt & " people."
End If

'Text to display at the end
revSummary = "REVISIONS:" & vbNewLine & "Extracted:" & vbTab & vbTab & vbTab & revTally & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & strRevPerPeop & vbNewLine & vbNewLine & "Total in document:" _
& vbTab & vbTab & indelCount & " tracked insertions/deletions" & vbNewLine _
& vbTab & vbTab & vbTab & "from " & lRn & " people." & vbNewLine & vbNewLine & vbNewLine

crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Application.ScreenUpdating = True
Application.Screenrefresh

EndRevCount:
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'Makes the grid


Public Sub iv_Grid_maker()
Dim oNewDoc As Document
Dim oTbl As Table
Dim NXTA As Boolean, NXTR As Boolean
Dim lngIndex As Long, lngComments As Long, lngRow As Long, lngIndexA As Long, lngIndexB As Long
Dim oRevRange As Range
Dim Rvtype As String, Rvpage As String, Rvsort As String, Rvauth As String, Rvtext As String

Set oDoc = ActiveDocument
lngRevisions = oDoc.Revisions.Count
lngComments = oDoc.Comments.Count
If cmInc = False And revInc = False Then
MsgBox "No comments or revisions selected.", vbOKOnly + vbInformation
GoTo lbl_Exit
End If
Application.ScreenUpdating = False

'This section builds the initial grid
Set oNewDoc = Documents.Add
With oNewDoc
.PageSetup.Orientation = wdOrientLandscape
Select Case True
Case cmInc And revInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Comments and revisions extracted from: " & oDoc.Name
Case cmInc And Not revInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Comments extracted from: " & oDoc.Name
Case revInc And Not cmInc
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Revisions extracted from: " & oDoc.Name
End Select
With .Styles(wdStyleNormal)
.Font.Name = "Calibri"
.Font.Size = 9
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
Set oTbl = .Tables.Add(Selection.Range, lngComments + lngRevisions + 1, 7)
With oTbl
.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
With .Rows(1)
.HeadingFormat = True
.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"
'The sort column is just for sorting revisions and comments by line number. It is deleted during finalisation
.Cells(7).Range.Text = "Sort"
End With
End With
End With

'Collects comments for the grid
If cmInc = True Then
lngRow = 1
For lngIndex = 1 To lngComments
With oDoc
NXTA = False
If cmEx = True Then
For lngIndexA = LBound(Cmt2exArr) To UBound(Cmt2exArr)
If .Comments(lngIndex).Author = Cmt2exArr(lngIndexA) Then NXTA = True
Next
End If
If NXTA = False Then
lngRow = lngRow + 1
oTbl.Rows.Add
With oTbl.Rows(lngRow)
.Cells(1).Range.Text = oDoc.Comments(lngIndex).Scope.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = "Comment"
.Cells(3).Range.Text = oDoc.Comments(lngIndex).Range.Text
.Cells(4).Range.Text = oDoc.Comments(lngIndex).Scope
.Cells(5).Range.Text = oDoc.Comments(lngIndex).Author
.Cells(7).Range.Text = oDoc.Comments(lngIndex).Scope.Information(wdFirstCharacterLineNumber) 'For sorting
End With
End If
End With
Next
End If

'Collects tracked insertions and deletions for the grid
If revInc Then
Application.ScreenUpdating = False
With oDoc
Selection.HomeKey Unit:=wdStory

If (cmInc = False) Or (comSkip = True) Then lngRow = 1
On Error GoTo NextRevb
For lngIndex = 0 To lngRevisions

With oDoc
With Selection.NextRevision
NXTR = False
If revEx = True Then
For lngIndexB = LBound(Rev2exArr) To UBound(Rev2exArr)
If .Author = Rev2exArr(lngIndexB) Then NXTR = True
Next
End If
If NXTR = False Then
lngRow = lngRow + 1
If (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") And (.Type = wdRevisionDelete) Then
Rvtype = "Delete"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"
ElseIf (.Range.Text Like "*[ A-z0-9\,\.\?\(\)\;]*") And (.Type = wdRevisionInsert) Then
Rvtype = "Insert"
Rvpage = .Range.Information(wdActiveEndPageNumber)
Rvauth = .Author
Rvsort = .Range.Information(wdFirstCharacterLineNumber)
Rvtext = """" & .Range.Text & """"
Else
Rvtype = ""
Rvpage = ""
Rvauth = ""
Rvsort = ""
Rvtext = ""
End If
End If
End With
End With


If NXTR = False Then
With oNewDoc
oTbl.Rows.Add
With oTbl.Rows(lngRow)
.Cells(1).Range.Text = Rvpage
.Cells(2).Range.Text = Rvtype
.Cells(4).Range.Text = Rvtext
.Cells(5).Range.Text = Rvauth
.Cells(7).Range.Text = Rvsort

If Rvtype = "Delete" Then
.Cells(2).Range.Font.Color = wdColorRed
.Cells(4).Range.Font.Color = wdColorRed
ElseIf Rvtype = "Insert" = True Then
.Cells(2).Range.Font.Color = wdColorBlue
.Cells(4).Range.Font.Color = wdColorBlue
End If
End With
End With
End If
NextRevb:
oDoc.Activate
Next
End With
End If
oDoc.Activate
crsRng.Select
ActiveWindow.ActivePane.VerticalPercentScrolled = scrllPs
Finalise:
oNewDoc.Activate
With oTbl.Borders 'Applies line style to the grid
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
oTbl.Select

'This sorts the table entries by page number and location in page
With 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"
.Columns(7).Delete
End With

'Deletes any blank rows that have crept in
With oTbl
For lngIndex = .Rows.Count To 1 Step -1
If Len(.Rows(lngIndex).Range.Text) = 14 Then .Rows(lngIndex).Delete
Next lngIndex
End With
Application.ScreenUpdating = True
Application.Screenrefresh
oNewDoc.Activate
MsgBox cmSummary & revSummary & "Finished creating tracker.", vbOKOnly + vbInformation, "Job summary"
lbl_Exit:
Set oNewDoc = Nothing: Set oTbl = Nothing
End Sub

[gmaxey]

You are probably about ready to take this to the next level. Your message box Choose 1, 2, 3 or 4 should consider clicking the "X" or the "Cancel" button the same as entering 4.
Better yet, why not have a userform with checkbox for the user to decide how to proceed and a couple of multiselect listbox to choose which commenters, editors to include/exclude.

vbCritcal is usually associated with something critical. Consider vbInfomation.

[h2whoa]

You are probably about ready to take this to the next level. Your message box Choose 1, 2, 3 or 4 should consider clicking the "X" or the "Cancel" button the same as entering 4.
Better yet, why not have a userform with checkbox for the user to decide how to proceed and a couple of multiselect listbox to choose which commenters, editors to include/exclude.

vbCritcal is usually associated with something critical. Consider vbInfomation.

Yes, that would be perfect! I actually tried to do that, but wasn't sure how to not have it treat Cancel the same as "" + OK. I wanted to try and make sure that if a user accidentally pressed OK without inputting a value they would get the opportunity to retry, and I was beating my head against the wall for a bit before I decided to move on.

Take your point about vbCritical as well. It's a good suggestion, and I'll update that in the code.