我有一些代码可以将Word中的注释提取到Excel中。但是,它仅提取一个级别的标题(直接标题)。
我可以添加什么代码以在Excel的单独列中提取不同的标题级别?
我可以按样式选择这些不同的标题级别吗?如果我使用样式MyOwnHeading,则代码会将其作为标题。
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
答案 0 :(得分:0)
您直接调用的标题是通过以下方式检索的:
wDoc.Bookmarks("\HeadingLevel").Range
rngHeading.Collapse wdCollapseStart
Set rngHeading = rngHeading.Paragraphs(1).Range
Word的“ \ HeadingLevel”书签内置于Word中,并引用与给定的内置标题样式相关联的所有内容。不能用于其他样式。如果要使用“标题样式”获得所有更高级别的标题,则必须为此实现一个循环,并添加有关这些标题在工作簿中的输出位置和顺序的逻辑。对代码的以下修订在同一行的不同列中按顺序输出标题。如果跳过给定的标题,则该列将没有条目。
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