Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 26 of 26

Thread: Final hurdle for combined comment and revision grid

  1. #21
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  2. #22
    VBAX Regular
    Joined
    Oct 2016
    Posts
    45
    Location
    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.

  3. #23
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    I added the new IV portion and now the comments are not populating the table.

  4. #24
    VBAX Regular
    Joined
    Oct 2016
    Posts
    45
    Location
    Quote Originally Posted by Kilroy View Post
    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
    Last edited by h2whoa; 07-13-2018 at 08:27 AM.

  5. #25
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  6. #26
    VBAX Regular
    Joined
    Oct 2016
    Posts
    45
    Location
    Quote Originally Posted by gmaxey View Post
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •