如何解决Word VBA - 如何插入标题编号的引用；标题文字；要评论的列表项编号和列表项页码？
我想在我的 Word 文档中标记某些文本并添加带有各种引用的注释。 这是为了 a) 我可以在评论中输出/打印这些细节以供进一步处理 b) 如果文档发展和变化，评论的信息会更新。
我想包含在评论中的参考文献是：
文本可能如下所示：
1.0 标题文本
这是文档的第 1 页。
1.1 标题 B 文本
1.1.1 标题 C 文本
有了这个标题，第 2 页开始
2.0 标题 D 文本
2.1 标题 E 文本
2.1.1 标题 F 文本
期望的结果是，如果为选定的单词/文本插入 MS Word 气球注释，如以下示例中的“任意”一词：
任意 ---->（第 1.1.1 节标题 C 文本；第 [2] 段；第 2 页）
我已经设法提取了大部分内容，即除了段落/列表项编号和段落页码（对于我现在使用的页码，标题的页码）之外的所有引用。
这是我目前所拥有的：
Sub InsertCommentWithReferences()
Dim rng As Range
Dim iLevel As Integer
Dim sLevel As String
Dim mystring As String
Dim RefList As Variant
Dim row As Integer
Dim Message,Title,Default,myrequirement
'To hand over additional (requirement)text to be inserted at the beginning of the comment
'Message = "Enter the requirement number" ' Set prompt.
'Title = "Requirement number" ' Set title.
'Default = "" ' Set default.
'display message,title,and default value.
'myrequirement = InputBox(Message,Default)
Set rng = Selection.Range
iLevel = rng.Paragraphs(1).OutlineLevel
sLevel = "0"
mystring = Selection
sLevel = rng.ListFormat.ListString
' Collapse the range to start so as to not have to deal with '
' multi-segment ranges. Then check to make sure cursor is '
' within a table. '
Selection.Collapse Direction:=wdCollapseStart
If Not Selection.information(wdWithInTable) Then
MsgBox "Can only run this within a table"
Exit Sub
End If
' lookup paragraph number as a text string
' Here I do actually extract the paragraph number but just as string and not as a reference
' which can be updated if the numbering changes
row = Selection.information(wdEndOfRangeRowNumber)
Selection.Tables(1).Cell(row,-1).Select
paragraphstring = Selection.Paragraphs(1).Range.ListFormat.ListString
'MsgBox (paragraphstring)
Set rng = Selection.GoToPrevIoUs(wdGoToheading)
If rng.Paragraphs(1).OutlineLevel < iLevel Then
iLevel = rng.Paragraphs(1).OutlineLevel
Set rng = rng.Bookmarks("\line").Range
curr_headinglevel = rng.Paragraphs(1).OutlineLevel
curr_headingnumber = Selection.Paragraphs(1).Range.ListFormat.ListString
curr_headingtext = rng
End If
With Selection.Find
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Execute FindText:=mystring
End With
Selection.Comments.Add Range:=Selection.Range
temp = curr_headingnumber & " " & curr_headingtext
If Right(temp,1) = vbCr Then
temp = Left(temp,Len(temp) - 1)
End If
myheadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeheading)
For i = 1 To UBound(myheadings)
'debug
'MsgBox (Trim(myheadings(i)) & vbNewLine & temp)
If InStr(Trim(myheadings(i))," ") Then
'debug
'MsgBox ("double space")
Do
temp1 = myheadings(i)
myheadings(i) = Replace(myheadings(i),Space(2),Space(1))
Loop Until temp1 = myheadings(i)
End If
If InStr(Trim(myheadings(i)),temp) Then
'debug stuff
'tempheading = myheadings(i)
'MsgBox ("#" & tempheading & "#")
'If Left(tempheading,1) = " " Then
' tempheading = Trim(tempheading)
'End If
'Selection.TypeText Text:=("R# " & myrequirement & vbNewLine & "Section ")
Selection.TypeText Text:=("R#" & myrequirement & "#Section ")
Selection.InsertCrossReference ReferenceType:="heading",_
ReferenceKind:=wdNumberFullContext,_
ReferenceItem:=CStr(i),_
InsertAsHyperlink:=True,_
IncludePosition:=False,_
SeparateNumbers:=False,_
SeparatorString:=" "
Selection.TypeText Text:=(" ")
Selection.InsertCrossReference ReferenceType:="heading",_
ReferenceKind:=wdContentText,_
SeparatorString:=" "
Selection.TypeText Text:=("; Paragraph " & paragraphstring)
Selection.TypeText Text:=("; Page ")
Selection.InsertCrossReference _
ReferenceType:=wdRefTypeheading,_
ReferenceKind:=wdPageNumber,ReferenceItem:=i
End If
'debug
'MsgBox (temp & "#")
Next i
Set rng = nothing
End Sub
我需要帮助的是如何识别和插入相应列表项/段落编号的引用到评论中？所以用文字来说，这将是这样的：查看左侧的单元格，将指向列表项/段落编号的引用插入到注释（编号和页码）中，该编号可以在该单元格中找到。
如您在示例中所见，项目编号可以重复（在每个新标题处重新编号），并且它们没有标题那样的列表项文本，因此我无法搜索该文本。
任何提示将不胜感激。 请注意，我对 VBA 没有太多经验，以上内容是从许多其他问答主题中的各种其他示例中收集的。
非常感谢。
最好的问候， 迈克尔。
解决方法
您不需要在注释中存储任何数据以供以后提取。此外，这些存储的数据很可能会因评论创建和提取之间发生的编辑而失效。
以下宏将活动文档中的注释以及与注释关联的任何标题导出到一个新的 Excel 工作簿中，在同一行的不同列中按标题级别顺序。
Sub ExportWordComments()
' Requires reference to Microsoft Excel Object Library in VBA,Dim wdDoc As Document,wdCmt As Comment,wdRng As Range,i As Long,j As Long
Dim xlApp As New Excel.Application,xlWB As Excel.Workbook,xlRng As Excel.Range
xlApp.Visible = False
Set wdDoc = ActiveDocument
' Create & prepare a new Workbook.
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
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")
With wdRng
j = Split(.Paragraphs.First.Style,"Heading")(1)
With .Paragraphs.First.Range
xlRng.Offset(i,4 + j) = .ListFormat.ListString & " " & .Text
End With
End With
Do Until Split(wdRng.Paragraphs.First.Style," ")(1) = 1
wdRng.Start = wdRng.Start - 1
Set wdRng = wdRng.GoTo(What:=wdGoToBookmark,Name:="\HeadingLevel")
With wdRng
j = Split(.Paragraphs.First.Style," ")(1)
With .Paragraphs.First.Range
xlRng.Offset(i,4 + j) = .ListFormat.ListString & " " & .Text
End With
End With
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
您可以为数据添加更多列，例如：
.Scope.Paragraphs(1).Range.Text
.Scope.Paragraphs(1).Range.ListFormat.ListString
等等。
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
