VBA 使用 excel 数据搜索 word 文档并将结果粘贴到 table
VBA using excel data to search word document & pasting result into a table
所以我希望能够搜索一个 word 文档(大约 300 页)并找到某些短语(一个单词或两个单词由 space 分隔)(例如:Nationwide/Phrase 2/短语 3) 我在单独的 excel 文档 (C:/Test.xlsx) 的 'A' 列中。然后这个 'phrase' 将被复制并粘贴到另一个 word 文档中的 table 以及上下文('phrase' 前后 20 个字符)以及 page/line 数字成立。现在有人(我真的很感激)创建了以下使用数组的宏。不幸的是,我可能要查找大约 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
在 Excel 的打开实例中用活动 sheet 的 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)
回答者,传奇人物蒂姆·威廉姆斯!!!!真的很感谢!!!
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
所以我希望能够搜索一个 word 文档(大约 300 页)并找到某些短语(一个单词或两个单词由 space 分隔)(例如:Nationwide/Phrase 2/短语 3) 我在单独的 excel 文档 (C:/Test.xlsx) 的 'A' 列中。然后这个 'phrase' 将被复制并粘贴到另一个 word 文档中的 table 以及上下文('phrase' 前后 20 个字符)以及 page/line 数字成立。现在有人(我真的很感激)创建了以下使用数组的宏。不幸的是,我可能要查找大约 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
在 Excel 的打开实例中用活动 sheet 的 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)
回答者,传奇人物蒂姆·威廉姆斯!!!!真的很感谢!!!
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