添加用于从 Word 注释中提取标题到 Excel 中的代码 [英] Adding code for extracting Headings from Word Comments into Excel

问题描述

我有一些代码可以将 Word 中的注释提取到 Excel 中.但是，它只提取一级标题(直接标题).

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

我可以添加什么代码来在 Excel 的不同列中提取不同的标题级别?

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

我可以按样式选择这些不同的标题级别吗，例如如果我使用样式 MyOwnHeading，代码会选择它作为标题.

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

推荐答案

直接标题，如您所说，是通过以下方式检索的:

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

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

Word 的\HeadingLevel"书签内置于 Word 中，并引用与给定的内置标题样式相关联的所有内容.它不能用于其他伴奏.如果您想使用标题样式获得所有更高级别的标题，您必须为此实现一个循环，并添加有关这些标题将在您的工作簿中输出的位置和顺序的逻辑.以下对您的代码的修订在同一行的不同列中按顺序输出标题.如果跳过给定的标题，则该列没有条目.

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

这篇关于添加用于从 Word 注释中提取标题到 Excel 中的代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！