Question

所以我希望能够搜索word文档（大约300页）并找到某些短语（一个单词或两个单词用空格分隔）（例如：Nationwide / Phrase 2 / Phrase 3），我在列中单独的Excel文档的“A”（C：/Test.xlsx）。然后，这个“短语”将被覆盖并粘贴到另一个单词文档中的表格中以及上下文（在“短语”之前和之后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

Answer 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)

Answer 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

VBA使用excel数据搜索word文档＆amp;将结果粘贴到表格中

2 个答案: