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

' 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.MoveLeft Unit:=wdWord, Extend:=wdWord

figureCaption = Selection.Text

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

GoTo done:

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.MoveLeft Unit:=wdWord, Extend:=wdWord

figureCaption = Selection.Text

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

GoTo done:

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

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

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

' 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

' 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

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

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

' 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

' 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

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

' 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

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