Word: Exporting Comments to Excel

Once you mark up a document with comments, sometimes the format required is a separate Excel review comments sheet. This macro extracts the comments from Word and converts it into the Excel sheet, including page, section, and highlighted text.

• 1. It understands replies to comments (note that replies are broken in Word 2010, so the replies only work for Word 2013 and above).

  2. It references page numbers, line numbers, section numbers, paragraph numbers, figure numbers, figure numbers in tables, figure numbers with an extra paragraph in between the figure, and table numbers where available.

  3. If there is no table or figure number (auto numbered using a field), then it uses an ordinal, e.g. "p.2 3rd table"

  4. It handles comments that refer to multiple paragraphs by using "–" to identify multiple paras (e.g. p15 line 27 (§4.2 ¶5) – p16 line 14 (§4.2 ¶12))

  5. It uses "..." to indicate truncated text where the text is over 500 characters.

  6. It understands custom lists that are used to label paragraphs with classifications. For instance,  "(U) This is an unclassified paragraph" is counted as a paragraph, not an unnumbered list.

  7. If the selected text is less than 5 words, it shows the entire sentence and highlights the text as a way to provide context.

  8. It adds the Severity based on the following:

  9. Severity 1: comment is bold+italic

  10. Severity 2: comment is bold

  11. Severity 3: comment is italic

  12. Severity 4: comment is regular formatting (not bold nor italic)

There are some limitations such as floating objects, however it will provide as a minimum the page number and line number for any comment.

I can't figure out what's the best way to handle outline bulleted / hybrid lists like 1.a.bullet3.a. this is a real edge case which is really subjective and indeterminate! Sometimes they are indented strangely, sometimes it's a correctly outlined list, sometimes they are broken lists, etc. So in this case it just shows the single letter/bullet and the page/line number.

To install this:

• 1. Open Word.

  2. Press ALT-F11.

  3. Click on Normal > Modules.

  4. Add a new Module.

  5. In the blank code window, paste the macro.

Sub ExportComments()

' https://answers.microsoft.com/en-us/office/forum/office_2007-customize/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c

' Exports comments from a MS Word document to Excel and associates them with the heading paragraphs

' they are included in. Useful for outline numbered section, i.e. 3.2.1.5....

' Thanks to Graham Mayor, http://answers.microsoft.com/en-us/office/forum/office_2007-customize/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c

' and Wade Tai, http://msdn.microsoft.com/en-us/library/aa140225(v=office.10).aspx

' Need to set a VBA reference to "Microsoft Excel 14.0 Object Library"

' This means that from the VBA editor you should select Tools > References and check

' the box against Microsoft Excel. Otherwise Word will not know what to do with Excel commands

'

' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,

' FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE

' FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR

' OTHER DEALINGS IN THE SOFTWARE.

'

' Modified by Edward Chan to handle replies and add human readable page references.

'

'

' Todo: Handle outline bulleting better somehow

' Todo: Add figure caption to Issue field

' Todo: Don't rely on the figure field or table field. Instead look for a capital letter after the figure number (exclude spaces and non-alphanumerics)

' Todo: Add table column and row headings, base this on splitting the table where the same number of rows and columns as the same in that cell.

' Todo: Fix red highlighting to support sentences correctly where there is a paragraph break. Do this by creating custom sentence identification macro since built in sentence doesn't work

'

 Dim xlApp As Object

 Dim xlWB As Object

 Dim i As Integer, HeadingRow As Integer

 Dim objPara As Paragraph

 Dim objComment As Comment

 Dim strSection As String

 Dim strTemp

 Dim myRange As Word.Range

 Dim CommentNumber

 Dim objUndo As UndoRecord

 If ActiveDocument.Revisions.Count > 0 Then ' There are revisions, need to check what to put the comments against

    If ActiveWindow.View.RevisionsFilter.View = wdRevisionsViewOriginal Then

        ' Reject all changes initially so the comments align with the original document.

        'Declares the variable objUndo of the UndoRecord type

        Set objUndo = Application.UndoRecord

        'sets the object to an actual item on the undo stack

        objUndo.StartCustomRecord ("Undo Reject Revisions")

        ActiveDocument.RejectAllRevisions

        objUndo.EndCustomRecord

    Else

        ' Accept all changes initially so deleted stuff doesn't appear in the Issue column

        'Declares the variable objUndo of the UndoRecord type

        Set objUndo = Application.UndoRecord

        'sets the object to an actual item on the undo stack

        objUndo.StartCustomRecord ("Undo Reject Revisions")

        ActiveDocument.AcceptAllRevisions

        objUndo.EndCustomRecord

    End If

End If

' Create Excel Spreadsheet

 Set xlApp = CreateObject("Excel.Application")

 xlApp.Visible = True

 Set xlWB = xlApp.Workbooks.Add 'create a new workbook

 With xlWB.Worksheets(1)

 ' Create Heading

   HeadingRow = 1

   .Cells(HeadingRow, 1).Formula = "#"

   .Cells(HeadingRow, 2).Formula = "Ref"

   .Cells(HeadingRow, 3).Formula = "Date Raised"

   .Cells(HeadingRow, 4).Formula = "Issue"

   .Cells(HeadingRow, 5).Formula = "Suggested way ahead"

   .Cells(HeadingRow, 6).Formula = "Severity"

   .Cells(HeadingRow, 7).Formula = "Raised by"

   .Cells(HeadingRow, 8).Formula = "Close out comments"

   .Cells(HeadingRow, 11).Formula = "Status"

   strSection = "preamble" 'all sections before "1." will be labeled as "preamble"

   strTemp = "preamble"

   If ActiveDocument.Comments.Count = 0 Then

       MsgBox ("No comments")

       Exit Sub

   End If

'     On Error Resume Next

   CommentNumber = 0

   replyNumber = 0

   For i = 1 To ActiveDocument.Comments.Count

     Set myRange = ActiveDocument.Comments(i).Scope

     If ActiveDocument.Comments(i).Ancestor Is Nothing Then

        ' It's a comment

        replyNumber = 0

        CommentNumber = CommentNumber + 1

         strSection = ParentLevel(myRange) ' find the section heading for this comment

         'MsgBox strSection

         .Cells(CommentNumber + HeadingRow, 1).Formula = CommentNumber

         .Cells(CommentNumber + HeadingRow, 2).Formula = strSection

         If myRange.Paragraphs.Count > 1 Then ' There's more than one paragraph so add the last character reference

           strSection = ParentLevel(myRange.Characters.Last)

           .Cells(CommentNumber + HeadingRow, 2).Formula = .Cells(CommentNumber + HeadingRow, 2).Formula & " – " & strSection

         End If

'         .Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString

         .Cells(CommentNumber + HeadingRow, 3).Formula = Format(ActiveDocument.Comments(i).Date, "yyyy-mm-dd")

         ' Format the highlighted text

         If myRange.InlineShapes.Count > 0 Then

            ' It's an object

            .Cells(CommentNumber + HeadingRow, 4).Value = "See figure"

         ElseIf myRange.ShapeRange.Count > 0 Then

            ' It's an image

            .Cells(CommentNumber + HeadingRow, 4).Value = "See figure"

         ElseIf Len(ActiveDocument.Comments(i).Scope) > 500 Then

            ' It's a really long paragraph, so shorten with ellipsis

            .Cells(CommentNumber + HeadingRow, 4).Value = Left(ActiveDocument.Comments(i).Scope, 300) & "..." & Chr(10) & "..." & Right(ActiveDocument.Comments(i).Scope, 50)

         ElseIf UBound(Split(ActiveDocument.Comments(i).Scope, " ")) < 6 Then

            ' Less than 5 words so show entire paragraph and make the highlighted text bold.

            ' This is heaps more complicated than you'd think, because counting words in Word is inconsistent.

            ' The only way to be sure is to convert to text and remove numbering.

            Dim objUndo2 As UndoRecord

            ' Declares the variable objUndo of the UndoRecord type

            Set objUndo2 = Application.UndoRecord

            ' Sets the object to an actual item on the undo stack

            objUndo2.StartCustomRecord ("Undo Bold Highlight")

On Error Resume Next

            For N = 1 To myRange.Paragraphs.Count

              ' Clear formatting of paragraph

              myRange.Paragraphs(N).Range.Style = wdStyleNormal ' get rid of styles

              myRange.Paragraphs(N).Range.ListFormat.RemoveNumbers ' get rid of numbering

              myRange.Paragraphs(N).Range.Bold = False

              myRange.Paragraphs(N).Range.Font.Name = "Calibri"

              myRange.Paragraphs(N).Range.Font.Size = 11

              myRange.Paragraphs(N).Range.Font.ColorIndex = wdBlack

              myRange.Paragraphs(N).Range.Font.Borders.Enable = False

              myRange.Paragraphs(N).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

              ' Replace Tabs with spaces

              With ActiveDocument.Comments(i).Scope.Paragraphs(N).Range.Find

                .ClearFormatting

                .Replacement.ClearFormatting

                .Text = "^t"

                .Replacement.Text = " "

                .Forward = True

                .Wrap = wdFindStop

                .Format = False

                .MatchCase = False

                .MatchWholeWord = False

                .MatchWildcards = False

                .MatchSoundsLike = False

                .MatchAllWordForms = False

                .Execute Replace:=wdReplaceAll

              End With

              ' Replace paragraphs with paragraph markings

              With ActiveDocument.Comments(i).Scope.Paragraphs(N).Range.Find

                .ClearFormatting

                .Replacement.ClearFormatting

                .Text = "^p"

                .Replacement.Text = "¶"

                .Forward = True

                .Wrap = wdFindStop

                .Format = False

                .MatchCase = False

                .MatchWholeWord = False

                .MatchWildcards = False

                .MatchSoundsLike = False

                .MatchAllWordForms = False

                .Execute Replace:=wdReplaceAll

              End With

           Next N

'On Error GoTo 0

              If myRange.Paragraphs.Last.Range.Characters(myRange.Paragraphs.Last.Range.Characters.Count - 1).Text = "¶" Then

                ' If last is a paragraph mark then change it back.

                With ActiveDocument.Comments(i).Scope.Paragraphs.Last.Range.Find

                  .ClearFormatting

                  .Replacement.ClearFormatting

                  .Text = "¶"

                  .Replacement.Text = "^p"

                  .Forward = False

                  .Wrap = wdFindStop

                  .Format = False

                  .MatchCase = False

                  .MatchWholeWord = False

                  .MatchWildcards = False

                  .MatchSoundsLike = False

                  .MatchAllWordForms = False

                  .Execute Replace:=wdReplaceAll

                End With

              End If

            If UBound(Split(ActiveDocument.Comments(i).Scope, " ")) <> UBound(Split(ActiveDocument.Comments(i).Scope.Paragraphs(1).Range, " ")) Then

              ' Not all words are highlighted in the paragraph, so highlight those specific words

              ActiveDocument.Comments(i).Scope.Bold = True

              ActiveDocument.Comments(i).Scope.Font.ColorIndex = wdRed

            End If

            If myRange.Information(wdWithInTable) Then ' Tables do funny things to Word Sentence detection so just do whole para

              .Cells(CommentNumber + HeadingRow, 4) = ActiveDocument.Comments(i).Scope.Paragraphs(1).Range

            Else

              ActiveDocument.Comments(i).Scope.Paragraphs(1).Range.Copy

                If ActiveDocument.Comments(i).Scope.Sentences.Count = 1 Then

                  ' If it's only 1 sentence then copy that. Otherwise the paragraph has already been copied above.

                  With ActiveDocument.Comments(i).Scope.Paragraphs.Last.Range.Find

                    .ClearFormatting

                    .Replacement.ClearFormatting

                    .Text = "¶"

                    .Replacement.Text = "^p"

                    .Forward = False

                    .Wrap = wdFindStop

                    .Format = False

                    .MatchCase = False

                    .MatchWholeWord = False

                    .MatchWildcards = False

                    .MatchSoundsLike = False

                    .MatchAllWordForms = False

                    .Execute Replace:=wdReplaceAll

                  End With

                    ActiveDocument.Comments(i).Scope.Select

                    Selection.MoveRight

                    Selection.Sentences(1).Previous(Unit:=wdSentence, Count:=1).Select

                    Selection.Sentences(1).Next(Unit:=wdSentence, Count:=1).Select

                    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

                    Selection.Copy

                End If

              objUndo2.EndCustomRecord

              ActiveDocument.Undo 1

              .Cells(CommentNumber + HeadingRow, 4).Select

              .Paste

              '

              ' Delete the comments that seems to be added when pasted, looks to be a strange Word/Excel bug

              .Cells(CommentNumber + HeadingRow + 1, 4).Clear

              .Cells(CommentNumber + HeadingRow + 2, 4).Clear

            End If

         Else ' It's a short paragraph, so don't add ellipsis

            .Cells(CommentNumber + HeadingRow, 4).Value = ActiveDocument.Comments(i).Scope

         End If

         .Cells(CommentNumber + HeadingRow, 4).Borders.LineStyle = xlNone

         .Cells(CommentNumber + HeadingRow, 4).Interior.Color = xlNone

         .Cells(CommentNumber + HeadingRow, 4).HorizontalAlignment = xlLeft

         .Cells(CommentNumber + HeadingRow, 5).Formula = ActiveDocument.Comments(i).Range

         .Cells(CommentNumber + HeadingRow, 6).HorizontalAlignment = xlCenter

         .Cells(CommentNumber + HeadingRow, 6).Formula = "4"

         If ActiveDocument.Comments(i).Range.Characters(1).Font.Italic = True Then .Cells(CommentNumber + HeadingRow, 6).Formula = "3"

         If ActiveDocument.Comments(i).Range.Characters(1).Font.Bold = True Then .Cells(CommentNumber + HeadingRow, 6).Formula = "2"

         If ActiveDocument.Comments(i).Range.Characters(1).Font.Bold = True And ActiveDocument.Comments(i).Range.Characters(1).Font.Italic = True Then .Cells(CommentNumber + HeadingRow, 6).Formula = "1"

         .Cells(CommentNumber + HeadingRow, 7).HorizontalAlignment = xlCenter

         .Cells(CommentNumber + HeadingRow, 7).Formula = ActiveDocument.Comments(i).Initial

         .Cells(CommentNumber + HeadingRow, 11).Formula = "Open"

    Else ' It's a reply to a comment

        replyNumber = replyNumber + 1

        If replyNumber > 1 Then CellText = .Cells(CommentNumber + HeadingRow, 8).Formula & Chr(10) ' Append to previous reply

        If replyNumber = 1 Then CellText = "" ' It's the first reply so start with blank

        CellText = CellText & Format(ActiveDocument.Comments(i).Date, "yyyy-MM-dd") & " "

        CellText = CellText & ActiveDocument.Comments(i).Initial & ": "

        CellText = CellText & ActiveDocument.Comments(i).Range

        .Cells(CommentNumber + HeadingRow, 8).Formula = CellText

        .Cells(CommentNumber + HeadingRow, 11).Formula = "Pending Review"

    End If

    ' If it's marked done then close the comment

    If ActiveDocument.Comments(i).done = True Then .Cells(CommentNumber + HeadingRow, 11).Formula = "Closed"

   Next i

 End With

' Format spreadsheet

 With xlWB.Worksheets(1)

    .Columns("A:A").EntireColumn.AutoFit

    .Columns("B:B").ColumnWidth = 20.14

    .Columns("H:H").ColumnWidth = 26.14

    .Columns("E:E").ColumnWidth = 27.14

    .Columns("D:D").ColumnWidth = 26.57

    .Columns("C:C").ColumnWidth = 12.71

    .Columns("C:C").ColumnWidth = 11

    .Columns("B:B").WrapText = True

    .Columns("C:C").WrapText = True

    .Columns("D:D").WrapText = True

    .Columns("E:E").WrapText = True

    .Columns("H:H").WrapText = True

    .Cells.VerticalAlignment = xlTop

    .Columns("A:H").Font.Name = "Arial"

    .Columns("A:H").Font.Size = 10

 End With

 Set xlWB = Nothing

 Set xlApp = Nothing

 ' Now undo the Accept/Reject Revisions

 ActiveDocument.Undo 1

 End Sub

Function ParentLevel(arange As Word.Range) As String

    ' Returns a human readable location for a certain paragraph.

    ' Edward Chan 2020

    Dim para As Word.Paragraph

    Dim paraAbove As Word.Paragraph

    Dim HeadAbove As Word.Paragraph

    Dim N As Integer

    Set para = arange.Paragraphs(1)

On Error GoTo none:

    ' Is it an inline figure with a caption?

   Debug.Print para.Range.Text

    If Left(para.Range.Text, 1) = "/" _

    Or para.Range.ShapeRange.Count > 0 _

    Or para.Range.InlineShapes.Count > 0 Then

        Dim paraAfter As Paragraph

        Dim figureCaption As String

        ' Test if the caption is in the paragraph below the picture

        Set paraAfter = para.Next ' Get the next paragraph

        paraAfter.Range.Select

        Selection.MoveLeft Unit:=wdCharacter, Count:=1 ' Required to avoid selecting entire table cells.

        If Not (Selection.NextField Is Nothing) Then ' Get the next range

          ' It should be in this paragraph if it's the real caption

          If Selection.Paragraphs(1).Range.Text = paraAfter.Range.Text Then

          ' Select the first field before this cell, then go back two words. This should say "Figure".

              Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend

              If LCase(Selection.Text) = "figure " Then ' Select the figure caption and copy the text.

                  Selection.MoveLeft Unit:=wdCharacter, Count:=1

'                  Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdSentence

                  Selection.Extend Character:=" "

                  Selection.Extend Character:=" "

                  Selection.MoveLeft Unit:=wdWord, Extend:=wdWord

                  figureCaption = Selection.Text

                  ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & Trim(LCase(figureCaption))

                  GoTo done:

              End If

          End If

        End If

        ' Check the paragraph after that just in case there's a blank line or it's in a table

        Set paraAfter = para.Next.Next ' Get the next paragraph

        paraAfter.Range.Select

        Selection.MoveLeft Unit:=wdCharacter, Count:=1 ' Required to avoid selecting entire table cells.

        If Not (Selection.NextField Is Nothing) Then ' Get the next range

          If Selection.Paragraphs(1).Range.Text = paraAfter.Range.Text Then

          ' Select the first field before this cell, then go back two words. This should say "Figure".

              Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend

              If LCase(Selection.Text) = "figure " Then ' Select the figure caption and copy the text.

                 Selection.MoveLeft Unit:=wdCharacter, Count:=1

                Selection.Extend Character:=" "

                Selection.Extend Character:=" "

                Selection.MoveLeft Unit:=wdWord, Extend:=wdWord

                figureCaption = Selection.Text

                  ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & Trim(LCase(figureCaption))

                  GoTo done:

              End If

          End If

        End If

    End If

    ' Is it an inline figure without a caption?

    If Left(para.Range.Text, 1) = "/" Then

        currentShapeNumber = ActiveDocument.Range(0, para.Range.End).InlineShapes.Count

        currentShapePage = para.Range.Information(wdActiveEndPageNumber)

        N = 1

        For i = currentShapeNumber - 1 To 1 Step -1

            testShapePage = ActiveDocument.InlineShapes(i).Range.Information(wdActiveEndPageNumber)

            If testShapePage < currentShapePage Then Exit For

            N = N + 1 ' Count number of shapes on same page above current shape

        Next

        If N = 1 Then ' It's the first shape on the page

            If ActiveDocument.InlineShapes.Count = currentShapeNumber Then ' It's the last shape in the document so don't include the ordinal

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " figure"

                GoTo done:

            End If

            If ActiveDocument.InlineShapes(currentShapeNumber + 1).Range.Information(wdActiveEndPageNumber) > currentShapePage Then ' The next shape is on a later page, so this is the last and only shape on the page

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " figure"

                GoTo done:

            End If

        End If

        ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & OrdinalNumber(N) & " figure"

        GoTo done:

    End If

    ' Is it in a table with a caption? Return the caption, row and column numbers.

    ' Note that table captions are traditionally above the table or in the first cell, not below the table.

    ' Also, it needs to be an auto-numbered caption. There's no easy way to tell if it's "Table 4 shows" or "Table 4:" unless it's auto-numbered.

    If para.Range.Information(wdWithInTable) Then

        Dim currentTableNumber As Integer

        Dim currentTable As Table

        Dim firstPara As Paragraph

        Dim tableCaption As String

        Dim paraBefore As Paragraph

        currentTableNumber = ActiveDocument.Range(0, para.Range.End).Tables.Count

        Set currentTable = ActiveDocument.Tables(currentTableNumber)

        ' Test if the caption is in the paragraph above the table

        Set paraBefore = currentTable.Cell(1, 1).Range.Paragraphs(1).Previous ' Get the paragraph before the current

        paraBefore.Range.Select

        Selection.NextField.Select ' Select the next field

        ' It should be in this paragraph if it's a real caption

        If Selection.Paragraphs(1).Range.Text = paraBefore.Range.Text Then

        ' Select the first field before this cell, then go back two words. This should say "Table".

            Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend

            If LCase(Selection.Text) = "table " Then ' Select the table caption and copy the text.

                Selection.MoveLeft Unit:=wdCharacter, Count:=1

                Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend

                tableCaption = Selection.Text

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & Trim(LCase(tableCaption)) & " row " & para.Range.Information(wdStartOfRangeRowNumber) & " col " & para.Range.Information(wdStartOfRangeColumnNumber)

                GoTo done:

            End If

        End If

        ' Test if the caption is in the first cell of the table

        Set paraBefore = currentTable.Cell(1, 1).Range.Paragraphs(1) ' Get the para in the first cell of the table

        paraBefore.Range.Select

        Selection.MoveLeft Unit:=wdCharacter, Count:=1

        Selection.NextField.Select ' Select the next field

        ' It should be in this paragraph if it's a real caption

        If Selection.Paragraphs(1).Range.Text = paraBefore.Range.Text Then

        ' Select the first field before this cell, then go back two words. This should say "Table".

            Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend

            If LCase(Selection.Text) = "table " Then ' Select the table caption and copy the text.

                Selection.MoveLeft Unit:=wdCharacter, Count:=1

                Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend

                tableCaption = Selection.Text

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & Trim(LCase(tableCaption)) & " row " & para.Range.Information(wdStartOfRangeRowNumber) & " col " & para.Range.Information(wdStartOfRangeColumnNumber)

                GoTo done:

            End If

        End If

    End If

    ' Is it in a table? Then return the row and column numbers. The table number is relative to the page

    If para.Range.Information(wdWithInTable) Then

'        Dim currentTableNumber As Integer

        currentTableNumber = ActiveDocument.Range(0, para.Range.End).Tables.Count

        currentTablePage = ActiveDocument.Tables(currentTableNumber).Range.Information(wdActiveEndPageNumber)

        N = 1

        For i = currentTableNumber - 1 To 1 Step -1

            testTablePage = ActiveDocument.Tables(i).Range.Information(wdActiveEndPageNumber)

            If testTablePage < currentTablePage Then Exit For

            N = N + 1 ' Count number of tables on same page above current table

        Next

        If N = 1 Then

            If ActiveDocument.Tables.Count = currentTableNumber Then ' It's the last shape in the document so don't include the ordinal

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " table row " & para.Range.Information(wdStartOfRangeRowNumber) & " col " & para.Range.Information(wdStartOfRangeColumnNumber)

                GoTo done:

            End If

            If ActiveDocument.Tables(currentTableNumber + 1).Range.Information(wdActiveEndPageNumber) > currentTablePage Then ' there's no other table on the same page so don't include ordinal

                ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " table row " & para.Range.Information(wdStartOfRangeRowNumber) & " col " & para.Range.Information(wdStartOfRangeColumnNumber)

                GoTo done:

            End If

        End If

        ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " " & OrdinalNumber(N) & " table row " & para.Range.Information(wdStartOfRangeRowNumber) & " col " & para.Range.Information(wdStartOfRangeColumnNumber)

        GoTo done:

    End If

    ' Is it a numbered heading? Then just use the heading number

    If Left(para.Range.ParagraphStyle, 4) = "Head" Then ' Is it a heading?

        If para.Range.ListParagraphs.Count = 1 Then ' It's numbered

            ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " §" & para.Range.ListFormat.ListString ' & " " & strTitle

            GoTo done:

        End If

    End If

    ' Is it an unnumbered heading? Then just use the page number and heading title.

    If Left(para.Range.ParagraphStyle, 4) = "Head" Then ' Is it a heading?

        If para.Range.ListParagraphs.Count <> 1 Then ' It's not numbered

            strTitle = para.Range.Text

            strTitle = Left(strTitle, Len(strTitle) - 1)

            ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " §" & strTitle

            GoTo done:

        End If

    End If

    ' OK, it's not a heading. So it's a paragraph.

    ' Find Numbered heading above current paragraph

    Set paraAbove = para

    N = 0

    Do

        Set paraAbove = paraAbove.Previous

        If paraAbove Is Nothing Then GoTo noHeadings ' There's no more paragraphs above, which means there aren't any headings left.

        If Left(paraAbove.Range.ParagraphStyle, 4) = "Head" Or _

           Left(paraAbove.Range.ParagraphStyle, 5) = "Annex" Then

            If paraAbove.Range.ListParagraphs.Count = 1 Then ' It's numbered

                Set HeadAbove = paraAbove

                ' It's a numbered heading, so exit the loop

                 N = N + 1

                Exit Do

            Else ' It's an unnumbered heading, so just use the default.

              GoTo noHeadings:

            End If

        Else ' it's not a heading

            If paraAbove.Range.ListFormat.ListString = "" Then N = N + 1 ' Count the paragraphs that aren't lists or outline numbered

            ' Cater for classification markings

            If paraAbove.Range.ListFormat.ListLevelNumber = 1 Then ' Can't AND everything or it'll bomb out sometimes since the tests need to be done one after the other

              If Not paraAbove.Range.ListFormat.ListTemplate Is Nothing Then

                If paraAbove.Range.ListFormat.ListTemplate.ListLevels(1).NumberStyle = wdListNumberStyleNone Then

                  N = N + 1

                End If

              End If

            End If

            If N > 20 Then GoTo noHeadings ' Too many paragraphs from the heading, let's give up and show something at least countable.

        End If

    Loop

    ' Is it a legal numbered para? Then use the para number

    If para.Range.ListFormat.ListString <> "" Then ' Is it a numbered para?

        If InStr(para.Range.ListFormat.ListString, HeadAbove.Range.ListFormat.ListString) Then ' It's a genuine Outline Numbered para, not just an outline indented list

            ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " ¶" & para.Range.ListFormat.ListString

            GoTo done:

        End If

    End If

    ' Is it an unnumbered para? Then use the relative para number from the last numbered heading

    If para.Range.ListFormat.ListString = "" Then

        ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " (§" & HeadAbove.Range.ListFormat.ListString & " ¶" & N & ")"

        GoTo done:

    End If

    ' Is it a bulleted list? Then return the relative para number from the last numbered heading

'

' Todo should return the count from the previous un-bulletted paragraph

'

    If para.Range.ListFormat.ListType = wdListBullet Then

        ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " (§" & HeadAbove.Range.ListFormat.ListString & " ¶" & N & ")"

        GoTo done:

    End If

    ' Does it have a classification marking?

    If para.Range.ListFormat.ListLevelNumber = 1 And _

       para.Range.ListFormat.ListTemplate.ListLevels(1).NumberStyle = wdListNumberStyleNone Then

            ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " §" & HeadAbove.Range.ListFormat.ListString & " ¶" & N

       GoTo done:

    End If

    ' Is it a numbered list? Then return the relative subpara count and the list number. Don't bother parsing outline numbered lists - it's crazy hard. It might be possible but then again Word is a little crazy when handling Outline Numbering. Best not to go there.

   ' Para.Range.Listformat.ListTemplate.ListLevels(1).NumberStyle '

    If para.Range.ListFormat.ListString <> "" Then ' Is there a numbered para?

        If InStr(para.Range.ListFormat.ListString, HeadAbove.Range.ListFormat.ListString) = 0 Then ' It's an outline indented list, not an Outline Numbered para

            If N = 0 Then

              ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " §" & HeadAbove.Range.ListFormat.ListString & " num " & para.Range.ListFormat.ListString

              GoTo done:

            Else

              ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " §" & HeadAbove.Range.ListFormat.ListString & " ¶" & N & " num " & para.Range.ListFormat.ListString

              GoTo done:

            End If

        End If

    End If

noHeadings:

    ' Is it a numbered list? Then return the list number.

    If para.Range.ListFormat.ListString <> "" Then ' Is there a numbered para?

      ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber) & " num " & para.Range.ListFormat.ListString

      GoTo done:

    End If

none:

    ' Well it's none of the above, so just return the line number relative to the top of the page. Who knows what strange thing Word has thrown up?

    ' e.g. floating figures, floating tables

    ParentLevel = "p" & arange.Information(wdActiveEndAdjustedPageNumber) & " line " & arange.Information(wdFirstCharacterLineNumber)

done:

 End Function

Function OrdinalNumber(ByVal Num As Long) As String

' https://wordpress.training-nyc.com/excel-training/formatting-numbers-ordinal-1st-2nd-3rd-4th-etc-excel-2010-training/

    Dim N As Long

    cSfx = "stndrdthththththth" ' 2 char suffixes

    N = Num Mod 100

    If ((Abs(N) >= 10) And (Abs(N) <= 19)) _

        Or ((Abs(N) Mod 10) = 0) Then

        OrdinalNumber = Num & "th"

    Else

        OrdinalNumber = Num & Mid(cSfx, (Abs(N) Mod 10) * 2 - 1, 2)

    End If

End Function

Sub FullOutlineNumberSub() ' This code doesn't work right now, but this outlined numbering thing is crazy hard, I mean if the formatting is bad then it's not outlined properly, and there is a lot of human subjectivity!

  Debug.Print FullOutlineNumber(Selection.Range.Paragraphs(1))

End Sub

Function FullOutlineNumber(para As Word.Paragraph) As String

  Dim paraAbove As Word.Paragraph

  With para.Range.ListFormat

    For i = 1 To .ListLevelNumber ' Go through the levels to determine the list number

      If .ListTemplate.ListLevels(1).NumberStyle = wdListNumberStyleBullet _

      Or .ListTemplate.ListLevels(1).NumberStyle = wdListNumberStyleNone _

      Then ' It's bulleted or not numbered so count the items above

        N = 1

        Set paraAbove = para

        Do ' Count number of list items above

            Set paraAbove = paraAbove.Previous

paraAbove.Range.Select

Debug.Print paraAbove.Range.ListFormat.ListLevelNumber

            If Left(paraAbove.Range.ParagraphStyle, 4) = "Head" Then Exit Do

'            Debug.Print para.Range.Listformat.ListValue

            If paraAbove.Range.ListFormat.ListLevelNumber = i Then N = N + 1

            If paraAbove.Range.ListFormat.ListLevelNumber < i Then Exit Do

        Loop

        FullOutlineNumber = FullOutlineNumber & "." & N

      Else ' It's a number or letter formatted list so return the list item

        FullOutlineNumber = FullOutlineNumber & "." & .ListString

      End If

    Next i

  End With

  FullOutlineNumber = Right(FullOutlineNumber, Len(FullOutlineNumber) - 1)

End Function

Function StepLeftSentence()

'https://wordribbon.tips.net/T010275_Selecting_Sentences

    If Selection.Type <> wdNoSelection Then

        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove

    End If

    Selection.Sentences(1).Previous(Unit:=wdSentence, Count:=1).Select

End Function