怎样把大量Word文件中包含某字符串的句子整理到Excel中

beleqing

我的问题下图所示：



我想把某文件夹及其子文件夹下的所有Word文档里包含 interesting 字符串的句子整理到根目录Excel文件里。

句子截取规则：发现 interesting 字符串后，截取完整句子，以句号 "." 开始（如果没有句号 "." ，则从第一个字母开始截取），以句号 "." 终止。

整理到Excel文件后用 "__________"替换interesting 字符串。

求助文件附件已上传。谢谢大家！

summary.zip (33.1 KB, 下载次数: 22)

2018-9-20 14:31 上传

点击文件名下载附件

182197315

Sub 提取()
    Dim fso As Object, Folder As Object, arr$(), brr(1 To 100, 1 To 1), m%, i%
    Dim wdApp As New Word.Application, wdD As Word.Document, tempRange As Word.Range
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = fso.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = False
    Call GetFiles(Folder, arr, m)
    For i = 1 To m
        Set wdD = wdApp.documents.Open(arr(i))
        Set tempRange = wdD.Content
        With tempRange
            If .Find.Execute("interesting") Then
                .Expand wdSentence
                brr(i, 1) = Replace(.Text, "interesting", "____________")
            End If
        End With
        wdD.Close
    Next
    wdApp.Quit
    Range("A2").CurrentRegion.ClearContents
    Range("A2").Resize(m) = brr
    Set wdD = Nothing
    Set tempRange = Nothing
    Set Folder = Nothing
    Set File = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
End Sub

Sub GetFiles(ByVal Folder As Object, arr$(), m%)
    Dim SubFolder As Object
    Dim File As Object
    If Folder.Path <> ThisWorkbook.Path Then
        For Each File In Folder.Files
            If File.Name Like "*.doc?" Then
                m = m + 1
                ReDim Preserve arr(1 To m)
                arr(m) = File
            End If
        Next
    End If
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder, arr, m)
    Next
End Sub

beleqing

182197315 发表于 2018-9-20 19:20
Sub 提取()
    Dim fso As Object, Folder As Object, arr$(), brr(1 To 100, 1 To 1), m%, i%
    Dim  ...

首先谢谢大神，代码解决了我的问题。现在有一个新的问题，有时候一个Word文件搜索 “interesting”字符串会有多个结果（比如图片中右上的Word文件里有两句话包含字符串 “interesting”），请问如何将所有结果所在的句子给截取出来？
请问是要修改下列代码吗？

1. With tempRange
   
2.      If .Find.Execute("interesting") Then
   
3.           .Expand wdSentence
   
4.           brr(i, 1) = Replace(.Text, "interesting", "____________")
   
5.      End If

复制代码

谢谢！

lsdongjh

1. Option Explicit
   
2. Sub Test()
   
3.     Dim arrList As Variant, strContent As String
   
4.     Dim objReg As Object, strTemp As String, strPat As String
   
5.     Dim objMatchs As Object, objMatch As Object
   
6.     Dim arrResult As Variant, lngID As Long
   
7.    
   
8.     arrList = GetFileNameList(ThisWorkbook.Path, ".doc*")
   
9.     strContent = GetTextFromDoc(arrList)
   
10.     Debug.Print strContent
    
11.    
    
12.     strPat = "([^\.]*)interesting([^\.]*\.)"
    
13.     Set objReg = CreateObject("VBScript.RegExp")
    
14.     With objReg
    
15.         .Global = True
    
16.         .Pattern = strPat
    
17.     End With
    
18.     Set objMatchs = objReg.Execute(strContent)
    
19. 
    
20.     If objMatchs.Count = 0 Then Exit Sub
    
21.    
    
22.     ReDim arrResult(1 To objMatchs.Count, 1 To 1)
    
23.     lngID = 1
    
24.     For Each objMatch In objMatchs
    
25.         strTemp = objMatch
    
26.         strTemp = Replace(strTemp, "interesting", String(10, "_"))
    
27.         arrResult(lngID, 1) = Trim(strTemp)
    
28.         lngID = lngID + 1
    
29.     Next
    
30.    
    
31.     Sheet1.UsedRange.ClearContents
    
32.     Sheet1.Range("A1").Resize(UBound(arrResult), 1) = arrResult
    
33.     MsgBox "OK"
    
34. End Sub
    
35. 
    
36. '读取WORD 文档中的文字
    
37. Function GetTextFromDoc(arrFileList As Variant) As String
    
38.     Dim objWord As Object, objDoc As Object, lngR As Long
    
39.     Dim strPath As String, strFileName As String
    
40.     Dim strTemp As String
    
41.    
    
42.     Set objWord = CreateObject("word.application")
    
43.    
    
44.     For lngR = LBound(arrFileList) To UBound(arrFileList)
    
45.         strPath = arrFileList(lngR): strFileName = ""
    
46.         If strPath <> "" Then strFileName = Dir(strPath)
    
47.         If strFileName <> "" Then
    
48.             Set objDoc = objWord.Documents.Open(strPath, True, True)
    
49.             strTemp = strTemp & " " & objDoc.Content
    
50.             objDoc.Close False
    
51.         End If
    
52.     Next
    
53.    
    
54.     objWord.Quit
    
55.     Set objDoc = Nothing: Set objWord = Nothing
    
56.    
    
57.     strTemp = Replace(strTemp, Chr(10), " ")
    
58.     strTemp = Replace(strTemp, Chr(13), " ")
    
59.    
    
60.     GetTextFromDoc = strTemp
    
61. End Function
    
62. 
    
63. '得到当前目录及子目录下，指定后缀的文件列表
    
64. Function GetFileNameList(strPath As String, Optional strFileType As String = "*") As Variant
    
65.     Dim strFileList As String
    
66.     Dim arrResult As Variant
    
67. 
    
68.     With CreateObject("Wscript.Shell")
    
69.         strFileList = .exec("cmd /c dir /a-d/b/s/n " & strPath & " | findstr /I ." & strFileType).StdOut.Readall
    
70.     End With
    
71. 
    
72.     If strFileList = "" Then
    
73.         ReDim arrResult(1 To 1)
    
74.         arrResult(1) = "False"
    
75.     Else
    
76.         arrResult = Split(strFileList, vbCrLf)
    
77.     End If
    
78. 
    
79.     GetFileNameList = arrResult
    
80. End Function

复制代码