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