Extract Heading from Word to Excel

Question

I have a word document that contains comments. I have written a script to extract to Excel:

Comment Number
Page Number
Commenter's First Initial
Commenter's Last Name
The Date the comment was written
The Actual Comment

The issue I can't figure out is I need to also extract the Heading number and the text of that heading. I need a 7th column for the Heading that the comment is located in. For example, let's say I had a comment in a section that was under Heading "4.1 This is a heading". I need Heading number (4.1) and Heading Text (This is a heading) to be extracted along with the related comment.

To create Headings, I utilized the Headings function within Word on the Home tab of the Ribbon under Styles, .

Here's what i've written so far:

 Sub Export_Comments()

' Purpose: Search for comments in any text that's been pasted into
' this document, then export them into a new Excel spreadsheet.
' Requires reference to Microsoft Excel 15.0 Object Library in VBA,
' which should already be saved with as part of the structure of
' this .docm file.

Dim bResponse As Integer

' Exit routine if no comments have been found.
If ActiveDocument.Comments.Count = 0 Then
  MsgBox ("No comments found in this document")
  Exit Sub
Else
  bResponse = MsgBox("Do you want to export all comments to an Excel worksheet?", _
              vbYesNo, "Confirm Comment Export")
  If bResponse = 7 Then Exit Sub
End If

' Create a object to hold the contents of the
' current document and its text. (Shorthand
' for the ActiveDocument object.
Dim wDoc As Document
Set wDoc = ActiveDocument

' Create objects to help open Excel and create
' a new workbook behind the scenes.
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook

Dim i As Integer
Dim oComment As Comment         'Comment object

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

' Create a new Workbook. Shouldn't interfere with
' other Workbooks that are already open. Will have
' at least one worksheet by default.
Set xlWB = xlApp.Workbooks.Add

With xlWB.Worksheets(1).Range("A1")

  ' Create headers for the comment information
  .Offset(0, 0) = "Comment Number"
  .Offset(0, 1) = "Page Number"
  .Offset(0, 2) = "Reviewer Initials"
  .Offset(0, 3) = "Reviewer Name"
  .Offset(0, 4) = "Date Written"
  .Offset(0, 5) = "Comment Text"

  ' Export the actual comments information
  For i = 1 To wDoc.Comments.Count

    Set oComment = wDoc.Comments(i)
    .Offset(i, 0) = oComment.Index                                                'Comment Number
    .Offset(i, 1) = oComment.Reference.Information(wdActiveEndAdjustedPageNumber) 'Page Number
    .Offset(i, 2) = oComment.Initial                                              'Author Initials
    .Offset(i, 3) = oComment.Author                                               'Author Name
    .Offset(i, 4) = Format(oComment.Date, "mm/dd/yyyy")                           'Date of Comment
    .Offset(i, 5) = oComment.Range                                                'Actual Comment
  Next i

End With

' Make the Excel workbook visible
xlApp.Visible = True

' Clean up our objects
Set oComment = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Cindy Meister Cindy Meister · Accepted Answer · 2018-06-13T13:24:56

You can get the Heading (defined by having applied one of nine possible Heading styles) for a particular location using a built-in bookmark having the name \HeadingLevel. For this to work, the selection needs to be at that Range. This returns the entire text under the heading, so it needs to be collapsed to its starting point, then the code works with that paragraph to get the ListString (numbering) and the text.

The Range of a comment in a document is the Comment.Reference.

Building on your code the following works in my test environment (Word):

Dim rngComment As Word.Range, rngHeading As Word.Range

Set rngComment = oComment.Reference
rngComment.Select
Set rngHeading = ActiveDocument.Bookmarks("\HeadingLevel").Range
rngHeading.Collapse wdCollapseStart
Set rngHeading = rngHeading.Paragraphs(1).Range
Debug.Print rngHeading.ListFormat.ListString & " " & rngHeading.Text

I can't duplicate your environment, but the following should work

 For i = 1 To wDoc.Comments.Count
   Set oComment = wDoc.Comments(i)
   Set rngComment = oComment.Reference
   rngComment.Select
   Set rngHeading = wDoc.Bookmarks("\HeadingLevel").Range
   rngHeading.Collapse wdCollapseStart
   Set rngHeading = rngHeading.Paragraphs(1).Range
  .Offset(i, 0) = oComment.Index
  .Offset(i, 1) = oComment.Reference.Information(wdActiveEndAdjustedPageNumber)
  .Offset(i, 2) = oComment.Initial    
  .Offset(i, 3) = oComment.Author
  .Offset(i, 4) = Format(oComment.Date, "mm/dd/yyyy")
  .Offset(i, 5) = oComment.Range
  .Offset(i, 6) = rngHeading.ListFormat.ListString & " " & rngHeading.Text
Next i

Extract Heading from Word to Excel

1 Answers