VBA使用excel数据搜索word文档并将结果粘贴到表格中答案

【问题标题】：VBA using excel data to search word document & pasting result into a tableVBA使用excel数据搜索word文档并将结果粘贴到表格中
【发布时间】：2015-03-04 21:06:56
【问题描述】：

所以我希望能够搜索一个 word 文档（大约 300 页）并找到我在列中的某些短语（一个单词或两个由空格分隔的单词）（例如：Nationwide/Phrase 2/Phrase 3）单独的 excel 文档 (C:/Test.xlsx) 的“A”。然后，这个“短语”将被复制并粘贴到另一个 Word 文档中的表格中，连同找到的页/行号的上下文（“短语”之前和之后的 20 个字符）。现在有人（我真的很感激）创建了以下使用数组的宏。不幸的是，我可能要查找大约 100-200 个单词，但我无法将它们全部包含在数组中或使用 excel 文档作为数据。

这是目前的代码

非常感谢您看这个！！！！！

    Sub CopyKeywordPlusContext()
'Modified 2-17-2015 GKM
'Makro created on 22.01.2013
Dim oDoc As Document, oDocRecord As Document
Dim strSearch As String, arrSearch
Dim lngCharTrailing As Long, lngCharLeading As Long, lngIndex As Long, lngCount As Long
Dim lngPgNum, lngLineNum As Integer
Dim oRng As Word.Range, oRngSpan As Word.Range
Dim bFound As Boolean
Dim oTbl As Word.Table
  strSearch = vbNullString
Dim xl As Object
Set xl = GetObject(, "Excel.Application")
arrSearch = xl.transpose(xl.activesheet.Range("A1:A14").Value)
  lngCharLeading = 20
  lngCharTrailing = 20
  Set oDoc = ActiveDocument
  For lngIndex = 1 To UBound(arrSearch)
    ResetFRParams
    bFound = False
    lngCount = 0
    Set oRng = oDoc.Range
    With oRng.Find
      .Text = LCase(arrSearch(lngIndex))
      While .Execute
        bFound = True
        If oDocRecord Is Nothing Then
          Set oDocRecord = Documents.Add
          Set oTbl = oDocRecord.Tables.Add(oDocRecord.Range, 1, 2)
        End If
        lngCount = lngCount + 1
        If lngCount = 1 Then
          oTbl.Rows.Add
          With oTbl.Rows.Last.Previous
            .Cells.Merge
            With .Cells(1).Range
              .Text = "Search results for """ & arrSearch(lngIndex) & """ + context in " & """" & oDoc.Name & """"
              .Font.Bold = True
            End With
          End With
        End If
        Set oRngSpan = oRng.Duplicate
        oRngSpan.Select
        lngPgNum = Selection.Information(wdActiveEndPageNumber)
        lngLineNum = Selection.Information(wdFirstCharacterLineNumber)
        With oRngSpan
          .MoveStart wdCharacter, -lngCharLeading
          .MoveEnd wdCharacter, lngCharTrailing
          Do While oRngSpan.Characters.First = vbCr
            oRngSpan.MoveStart wdCharacter, -1
          Loop
          Do While oRngSpan.Characters.Last = vbCr
            oRngSpan.MoveEnd wdCharacter, 1
            If oRngSpan.End = oDoc.Range.End Then
              oRngSpan.End = oRngSpan.End - 1
              Exit Do
            End If
          Loop
        End With
        oTbl.Rows.Last.Range.Cells(1).Range.Text = Trim(oRngSpan.Text)
        oTbl.Rows.Last.Range.Cells(2).Range.Text = "Page: " & lngPgNum & " Line: " & lngLineNum
        oTbl.Rows.Add
      Wend
    End With
    If bFound Then
      ResetFRParams
      With oDocRecord.Range.Find
        .Text = LCase(arrSearch(lngIndex))
        .Replacement.Text = "^&"
        .Replacement.Highlight = True
        .Format = True
        .Execute Replace:=wdReplaceAll
      End With
    End If
  Next lngIndex
  oTbl.Rows.Last.Delete
End Sub
Sub ResetFRParams()
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Replacement.Highlight = False
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
lbl_Exit:
  Exit Sub
End Sub

【问题讨论】：

标签： vba excel ms-word

【解决方案1】：

使用打开的 Excel 实例中活动工作表的 colA 中的值填充数组（注意只能打开一个 excel 实例，否则可能会得到错误的实例）：

替换

arrSearch = Split("Nationwide,Phrase 2,Phrase 3", ",")

与

Dim xl As Object
Set xl = GetObject(, "Excel.Application")
arrSearch = xl.transpose(xl.activesheet.Range("A1:A14").Value)

和

For lngIndex = 0 To UBound(arrSearch)

与

For lngIndex = 1 To UBound(arrSearch)

【讨论】：

非常感谢您花时间回答我！我得试试看！非常感谢先生！！
代替Dim arrSearch() As String 试试Dim arrSearch。如果这不是问题，那么它会帮助您准确指定错误发生的位置。
对不起，我正试图编辑我的评论，然后我看到你回复了。道歉
错误出现在以下行 --- arrSearch = xlApp.transpose(xlApp.activesheet.Range("A1:A14").Value)
而且修改了变量声明后还是报错吗？

【解决方案2】：

由传奇人物蒂姆威廉姆斯回答！！！！真的很感谢！！！

   Sub CopyKeywordPlusContext()
'Modified 2-17-2015 GKM
'Makro created on 22.01.2013
Dim oDoc As Document, oDocRecord As Document
Dim strSearch As String, arrSearch
Dim lngCharTrailing As Long, lngCharLeading As Long, lngIndex As Long, lngCount As Long
Dim lngPgNum, lngLineNum As Integer
Dim oRng As Word.Range, oRngSpan As Word.Range
Dim bFound As Boolean
Dim oTbl As Word.Table
  strSearch = vbNullString
Dim xl As Object
Set xl = GetObject(, "Excel.Application")
arrSearch = xl.transpose(xl.activesheet.Range("A1:A14").Value)
  lngCharLeading = 20
  lngCharTrailing = 20
  Set oDoc = ActiveDocument
  For lngIndex = 1 To UBound(arrSearch)
    ResetFRParams
    bFound = False
    lngCount = 0
    Set oRng = oDoc.Range
    With oRng.Find
      .Text = LCase(arrSearch(lngIndex))
      While .Execute
        bFound = True
        If oDocRecord Is Nothing Then
          Set oDocRecord = Documents.Add
          Set oTbl = oDocRecord.Tables.Add(oDocRecord.Range, 1, 2)
        End If
        lngCount = lngCount + 1
        If lngCount = 1 Then
          oTbl.Rows.Add
          With oTbl.Rows.Last.Previous
            .Cells.Merge
            With .Cells(1).Range
              .Text = "Search results for """ & arrSearch(lngIndex) & """ + context in " & """" & oDoc.Name & """"
              .Font.Bold = True
            End With
          End With
        End If
        Set oRngSpan = oRng.Duplicate
        oRngSpan.Select
        lngPgNum = Selection.Information(wdActiveEndPageNumber)
        lngLineNum = Selection.Information(wdFirstCharacterLineNumber)
        With oRngSpan
          .MoveStart wdCharacter, -lngCharLeading
          .MoveEnd wdCharacter, lngCharTrailing
          Do While oRngSpan.Characters.First = vbCr
            oRngSpan.MoveStart wdCharacter, -1
          Loop
          Do While oRngSpan.Characters.Last = vbCr
            oRngSpan.MoveEnd wdCharacter, 1
            If oRngSpan.End = oDoc.Range.End Then
              oRngSpan.End = oRngSpan.End - 1
              Exit Do
            End If
          Loop
        End With
        oTbl.Rows.Last.Range.Cells(1).Range.Text = Trim(oRngSpan.Text)
        oTbl.Rows.Last.Range.Cells(2).Range.Text = "Page: " & lngPgNum & " Line: " & lngLineNum
        oTbl.Rows.Add
      Wend
    End With
    If bFound Then
      ResetFRParams
      With oDocRecord.Range.Find
        .Text = LCase(arrSearch(lngIndex))
        .Replacement.Text = "^&"
        .Replacement.Highlight = True
        .Format = True
        .Execute Replace:=wdReplaceAll
      End With
    End If
  Next lngIndex
  oTbl.Rows.Last.Delete
End Sub
Sub ResetFRParams()
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Replacement.Highlight = False
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
lbl_Exit:
  Exit Sub
End Sub

【讨论】：