'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