Question

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

提供： word文件位于C：\ Test \ ACBS.docx，执行VBA宏的excel单独定位。在Excel中，搜索项变量“FindWord”位于A列中，注释是变量“CommentWord”，位于B列。

问题：如何才能搜索整个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:\Test\ACBS.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

将MS-Excel列导入MS-Word作为评论

1 个答案: