Adding code for extracting Headings from Word Comments into Excel

问题

I have some code for extracting Comments from Word into Excel. However, it only extracts one level of Heading (the direct heading).

What code can I add to extract different Heading levels in separate columns in Excel?

And can I select these different heading level by Style e.g. if I use style MyOwnHeading, the code would pick that up as the Heading.

Sub ExportWordComments()

' 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 16.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 Name"
  .Offset(0, 3) = "Date Written"
  .Offset(0, 4) = "Comment Text"
  .Offset(0, 5) = "Section"

  ' Export the actual comments information
  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.Author
  .Offset(i, 3) = Format(oComment.Date, "mm/dd/yyyy")
  .Offset(i, 4) = oComment.Range
  .Offset(i, 5) = rngHeading.ListFormat.ListString & " " & rngHeading.Text
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

回答1:

The direct heading, as you call it, is retrieved via:

wDoc.Bookmarks("\HeadingLevel").Range
rngHeading.Collapse wdCollapseStart
Set rngHeading = rngHeading.Paragraphs(1).Range

Word's "\HeadingLevel" bookmark is built into Word and references all content associated with a given built-in Heading Style. It cannot be used for other Styles. If you want to get all higher-level headings using Heading Styles, you'd have to implement a loop for that, plus adding the logic as to where and in what order those headings would be output in your workbook. The following revisions to your code outputs the headings in order in different columns on the same row. If a given heading is skipped, there is no entry for that column.

Sub ExportWordComments()

' 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 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 wdDoc As Document, wdCmt As Comment, wdRng As Range
Dim i As Long, j As Long
Set wdDoc = ActiveDocument

' Create objects to help open Excel and create
' a new workbook behind the scenes.
Dim xlApp As New Excel.Application, xlWB As Excel.Workbook, xlRng As Excel.Range
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

Set xlRng = xlWB.Worksheets(1).Range("A1")
With xlRng
  ' Create headers for the comment information
  .Offset(0, 0) = "Comment Number"
  .Offset(0, 1) = "Page Number"
  .Offset(0, 2) = "Reviewer Name"
  .Offset(0, 3) = "Date Written"
  .Offset(0, 4) = "Comment Text"
  .Offset(0, 5) = "Section"
End With
  ' Export the actual comments information
With wdDoc
  For Each wdCmt In .Comments
    With wdCmt
      i = i + 1
      If I Mod 100 = 0 Then DoEvents
      xlRng.Offset(i, 0) = .Index
      xlRng.Offset(i, 1) = .Reference.Information(wdActiveEndAdjustedPageNumber)
      xlRng.Offset(i, 2) = .Author
      xlRng.Offset(i, 3) = Format(.Date, "mm/dd/yyyy")
      xlRng.Offset(i, 4) = .Range.Text
      Set wdRng = .Scope
      Set wdRng = wdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      j = HeadingLevel(WdRng)
      xlRng.Offset(i, 4 + j) = WdRng.Paragraphs.First.Range.ListFormat.ListString & " " & WdRng.Text
      Do Until WdRng.Paragraphs.First.Style = wdStyleHeading1
        WdRng.Start = WdRng.Start - 1
        Set WdRng = WdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        j = HeadingLevel(WdRng)
        xlRng.Offset(i, 4 + j) = WdRng.Paragraphs.First.Range.ListFormat.ListString & " " & WdRng.Text
      Loop
    End With
  Next
End With

' Make the Excel workbook visible
xlApp.Visible = True

' Clean up our objects
Set wdRng = Nothing: Set wdCmt = Nothing: Set wdDoc = Nothing
Set xlRng = Nothing: Set xlWB = Nothing: Set xlApp = Nothing
End Sub

Function HeadingLevel(WdRng As Range)
Select Case WdRng.Paragraphs.First.Style
  Case wdStyleHeading1: j = 1
  Case wdStyleHeading2: j = 2
  Case wdStyleHeading3: j = 3
  Case wdStyleHeading4: j = 4
  Case wdStyleHeading5: j = 5
  Case wdStyleHeading6: j = 6
  Case wdStyleHeading7: j = 7
  Case wdStyleHeading8: j = 8
  Case wdStyleHeading9: j = 9
End Select
End Function

来源：https://stackoverflow.com/questions/55856477/adding-code-for-extracting-headings-from-word-comments-into-excel

标签

excel

vba

ms-word