将 MS-Excel 列作为注释导入 MS-Word

Question

>情况：我正在尝试在 Word 文档中搜索 excel 中包含的关键字/ID，并将电子表格中的注释添加到 Word 文档中，以便每次出现关键字/ID 然后保存。我的示例代码贯穿关键字/ID 列表，但只注释第一次出现

给：word 文件位于 C：\Test\ACBS.docx执行 VBA 宏的 Excel 位于单独的位置。 在Excel中，搜索词变量"FindWord"位于A列中，注释是B列中的变量"CommentWord"。

问题：如何让它搜索整个 Word 文档并注释关键字/ID 的每个出现？

法典：

Sub Comments_Excel_to_Word()
'Author: Paul Keahey
'Date: 2017-10-30
'Name:Comments_Excel_to_Word
'Purpose: To bring in comments From Excel to Word.
'Comments: None
Dim objWord
Dim objDoc
Dim objSelection
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:TestACBS.docx")
objWord.Visible = True
Set objSelection = objWord.Selection
Dim oRng As Word.range
Set oRng = objSelection.range
Set oScope = oRng.Duplicate
Dim oCol As New Collection
Dim FindWord As String
Dim CommentWord As String
Dim I As Integer

'initalize list of varables

For I = 2 To range("A1").End(xlDown).Row
FindWord = Sheet1.range("A" & I).Value
CommentWord = Sheet1.range("B" & I).Value
 With oRng.Find
    .Text = FindWord
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = True
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    Do While .Execute = True
        If oRng.InRange(oScope) Then
            On Error Resume Next
            'MsgBox "oRng.InRange(oScope)"
            oCol.Add oRng.Text, oRng.Text
            On Error GoTo 0
                oRng.Collapse wdCollapseEnd
                Else
             ActiveDocument.Comments.Add oRng, CommentWord
                Exit Do
            End If
        Loop
    End With
Next I
objDoc.Save
End Sub

Answer 1

我不确定我是否理解此设置的 Word 组件，但如果您想列出 Excel 文件中的所有注释，您可以使用下面的脚本来执行此操作。

Sub ShowCommentsAllSheets()
'Update 20140508
Dim commrange As Range
Dim rng As Range
Dim ws As Worksheet
Dim newWs As Worksheet
Set newWs = Application.Worksheets.Add
newWs.Range("A1").Resize(1, 4).Value = Array("Sheet", "Address", "Value", "Comment")
Application.ScreenUpdating = False
On Error Resume Next
For Each ws In Application.ActiveWorkbook.Worksheets
    Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
    If Not commrange Is Nothing Then
        i = newWs.Cells(Rows.Count, 1).End(xlUp).Row
        For Each rng In commrange
            i = i + 1
            newWs.Cells(i, 1).Resize(1, 4).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text)
        Next
    End If
    Set commrange = Nothing
Next
newWs.Cells.WrapText = False
Application.ScreenUpdating = True
End Sub