您好,亲爱的论坛成员,
在我大学的研究工作中,我必须根据关键字将Word文档中的文本段落传输到Excel文件中。
这是关键字列表(在Excel列中彼此依次列出)和几个Word文档(大约80-100,每个400页)。
程序应在Word文档中搜索关键字,如果找到了一个单词,则该单词前后的相应单词+ 350个字符应复制到Excel行中。此外,应复制文档名称和页数。找到的每个单词都应复制到新行中。
根据Google的初步研究,我收到了以下代码。大多数代码已经可以使用此代码。
我需要您提供以下两点帮助:
1。)如何扩展要复制的文本?如果在单词文档中找到了搜索单词,则应复制单词前后的单词+ 350个字符。
2。)循环的外观如何,以便一个接一个地处理一个文件夹中的所有Word文档?
由于尝试了很长时间之后没有找到解决方案,所以我对每一个技巧或解决方案感到满意。
Sub LocateSearchItem_Test22()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim myLine As Long
Dim myPage As Long
Dim oDocName As Variant
On Error Resume Next
Application.ScreenUpdating = False
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\Testdatei.docx")
oDocName = ActiveDocument.Name
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
'.MatchWholeWord = False
.MatchWildcards = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
myPage = oWord.Selection.Information(wdActiveEndAdjustedPageNumber)
myLine = oWord.Selection.Information(wdFirstCharacterLineNumber)
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
shtExtract.Cells(CurrRowShtExtract, 6) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
我将特别关注Word部分,因为这是我的专长。看来您对VBA相当了解,所以我只用片段来回答。
这是您的发现:
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
'.MatchWholeWord = False
.MatchWildcards = True 'do you really want wildcards?
.Wrap = wdFindStop
While .Execute = True
myPara = oDoc.Range(0, oRange.End).Paragraphs.Count
myPage = oRange.Information(wdActiveEndAdjustedPageNumber)
myLine = oRange.Information(wdFirstCharacterLineNumber)
'Expand range size begins here
oRange.MoveStart wdCharacter, -350 'not sure if you want the info of just the word or the word +/- 350 characters
oRange.MoveEnd wdCharacter, 350
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
shtExtract.Cells(CurrRowShtExtract, 6) = oRange.Text
oRange.Collapse wdCollapseEnd
Wend
End With
如果可以提供帮助,请不要选择任何东西。无需使用选择就可以完成Word中的几乎所有操作。声明范围并操纵范围。无需选择它。
关于遍历文件夹中的每个文档,请看FileSystemObject
。该文档令人发指,但Google的搜索结果通常不错。