VBA/VBScript批量搜索多个Word或者Excel指定的包含文字

假设我们有多个Word或者Excel文件，现在我们要从这些文件中搜索特定的关键字，比较笨的办法就是一个一个打开，然后“编辑 – 查找”，文件少还好办，如果文件比较多的话，那么打开这么多文件也累得我们够呛。

下面我讲解一个利用VBScript自动批量搜索特定文字的办法，首先还是上面的算法，只不过将人工一个一个打开换成计算机自动打开。实际上这里主要是枚举文件，然后在利用ActiveX控件调用Word.Application或者Excel.Application内部的查找方法来实现相关功能。

对于一份简单的Word文档，基本的查找VBA可以像下面这样实现：

Dim hasFound ' 定义是否找到
Selection.WholeStory
With Selection.Find
    .ClearFormatting
    .MatchWholeWord = False
    .MatchCase = False
    hasFound = .Execute("要查找的文字")
End With

转化为VBScript代码也很容易，多个创建Word.Application并打开Word文件的过程。

下面定义FileFinder接口，当然VBS没有接口的概念，我们只是象征式的说明下：

Interface FileFinder
    Function isTextExists(search, filename)
    End Function
End Interface

只需要实现一个方法接口，那就是isTextExists，判断要搜索的文本是否存在于指定的文件中。下面给出关于Word查找的VBS脚本代码实现：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

Class DocumentsFinder
 
    Private vbaObject
    Private Application
 
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Word.Application")
            vbaObject.Visible = False
    End Sub
 
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
 
    Private Function SearchStringInSingleDocument(str, doc)
        Dim Selection
        Set Selection = vbaObject.Selection
            Selection.WholeStory
            With Selection.Find
                .ClearFormatting
                .MatchWholeWord = False
                .MatchCase = False
                SearchStringInSingleDocument =.Execute(str)
            End With
        Set Selection = Nothing
    End Function
 
    Public Function isTextExists(str, filename)
        On Error Resume Next
        Dim doc
        Set doc = vbaObject.Documents.Open(filename)
            isTextExists = SearchStringInSingleDocument(str, doc)
            doc.Close
        Set doc = Nothing
        If Err Then Err.Clear
    End Function
End Class

其中调用了Documents.Open打开一个Word文档，然后再通过SearchStringInSingleDocument方法来搜索指定文档的文字，这个方法就是刚才讲解的VBA宏的实现。

关于Excel的查找和Word稍有不同，大家知道一份Excel文件算是工作簿（WorkBook），工作簿里面有多个工作表（WorkSheet），比如Sheet1、Sheet2等，所以我们需要搜索当前工作簿下的所有工作表，然后通过调用Sheet.Cells.Find方式来检索文字是否存在，关于Excel的Find查找文字的方式可以参考微软的《Cells.Find 返回错误时找到不匹配》，基本VBA代码如下：

Dim hasFound ' 定义是否找到
Dim RangeObj
For Each Sheet In Workbooks.Worksheets
    Set RangeObj = Sheet.Cells.Find(str)
    hasFound = CBool(Not (RangeObj Is Nothing))
    Set RangeObj = Nothing
    If hasFound Then Exit For
Next

基于刚才叙述的FileFinder接口，相关代码实现如下：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

Class WorkbooksFinder
 
    Private vbaObject
    Private Application
 
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Excel.Application")
            vbaObject.Visible = False
    End Sub
 
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
 
    Private Function SearchStringInSingleSheet(str, sheet)
        ' See http://support.microsoft.com/kb/108892
        Dim RangeObj
        Set RangeObj = sheet.Cells.Find(str)
            SearchStringInSingleSheet = CBool(Not (RangeObj Is Nothing))
        Set RangeObj = Nothing
    End Function
 
    Public Function isTextExists(str, filename)
        On Error Resume Next
        isTextExists = False
        Dim Workbooks,Worksheets
        Set Workbooks = vbaObject.Workbooks.Open(filename)
 
        For Each Worksheets In Workbooks.Worksheets
            isTextExists = SearchStringInSingleSheet(str, Worksheets)
            If isTextExists Then Exit For
        Next
 
        Workbooks.Close
        Set Workbooks = Nothing
        If Err Then Err.Clear
    End Function
End Class

好了，关于Word和Excel的文字查找的实现代码都有了，接下来是万事俱备只欠东风了，东风就是文件枚举的代码实现。这点我在前面的文章《利用Scripting.FileSystemObject组件来枚举文件》已经介绍过方法了，大家可以移步围观下。

基于上面的工作，下面我实现了一个简单的批量搜索多个Word或者Excel指定的文字的小程序（github gist）供大家参考：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311

Option Explicit
 
Dim hasMatchCase
Dim hasRecursion
Dim includeDocuments
Dim includeWorkbooks
Dim stopIfFound
Dim lookupType
 
Dim SearchLists
 
Class DocumentsFinder
 
    Private vbaObject
    Private Application
 
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Word.Application")
            vbaObject.Visible = False
    End Sub
 
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
 
    Private Function SearchStringInSingleDocument(str, doc)
        Dim Selection
        Set Selection = vbaObject.Selection
            Selection.WholeStory
            With Selection.Find
                .ClearFormatting
                .MatchWholeWord = False
                .MatchCase = False
                SearchStringInSingleDocument =.Execute(str)
            End With
        Set Selection = Nothing
    End Function
 
    Public Function isTextExists(str, filename)
        On Error Resume Next
        Dim doc
        Set doc = vbaObject.Documents.Open(filename)
            isTextExists = SearchStringInSingleDocument(str, doc)
            doc.Close
        Set doc = Nothing
        If Err Then Err.Clear
    End Function
End Class
 
Class WorkbooksFinder
 
    Private vbaObject
    Private Application
 
    Private Sub Class_Initialize()
        Set vbaObject = WSH.CreateObject("Excel.Application")
            vbaObject.Visible = False
    End Sub
 
    Private Sub Class_Terminate()
            vbaObject.Visible = True
            vbaObject.Quit
        Set vbaObject = Nothing
    End Sub
 
    Private Function SearchStringInSingleSheet(str, sheet)
        ' See http://support.microsoft.com/kb/108892
        Dim RangeObj
        Set RangeObj = sheet.Cells.Find(str)
            SearchStringInSingleSheet = CBool(Not (RangeObj Is Nothing))
        Set RangeObj = Nothing
    End Function
 
    Public Function isTextExists(str, filename)
        On Error Resume Next
        isTextExists = False
        Dim Workbooks,Worksheets
        Set Workbooks = vbaObject.Workbooks.Open(filename)
 
        For Each Worksheets In Workbooks.Worksheets
            isTextExists = SearchStringInSingleSheet(str, Worksheets)
            If isTextExists Then Exit For
        Next
 
        Workbooks.Close
        Set Workbooks = Nothing
        If Err Then Err.Clear
    End Function
End Class
 
Function Dispatch(self, fso, file, params)
    Dispatch = False
    Const DOCUMENTS_FINDER = 0
    Const WORKBOOKS_FINDER = 1
    Const SEARCH_LIST_OBJECT = 2
    Const FOUND_LIST_OBJECT = 3
 
    Dim ObjectIndex : ObjectIndex = -1
    Select Case UCase(fso.GetExtensionName(file.Name))
        Case "DOC"
            ObjectIndex = DOCUMENTS_FINDER
        Case "XLS"
            ObjectIndex = WORKBOOKS_FINDER
    End Select
 
    If ObjectIndex < 0 Then Exit Function
 
    If Not (params(ObjectIndex) Is Nothing) Then
        If params(ObjectIndex) _
            .isTextExists(params(SEARCH_LIST_OBJECT), _
                        fso.GetAbsolutePathName(file)) Then
            ' 将找到文件对象输出
            WSH.Echo file.Name & " > " & fso.GetAbsolutePathName(file)
            ' 找到即停止
            If stopIfFound Then Dispatch = True
        End If
    End If
End Function
 
Sub Lookup(startFolder)
    Dim params(3)
 
    Set params(0) = Nothing
    Set params(1) = Nothing
 
    If includeDocuments Then
        Set params(0) = New DocumentsFinder
    End If
 
    If includeWorkbooks Then
        Set params(1) = New WorkbooksFinder
    End If
 
    params(2) = SearchLists
 
    'Set params(3) = FoundLists
 
    Dim fp
    Set fp = New FileOperation
        fp.EnumFiles startFolder, "Dispatch", hasRecursion, params
    Set fp = Nothing
 
    'Set params(3) = Nothing
    Set params(2) = Nothing
    Set params(1) = Nothing
    Set params(0) = Nothing
End Sub
 
Sub VBMain()
    hasMatchCase = False
    includeDocuments = True
    includeWorkbooks = True
    hasRecursion = True
    SearchLists = ""
 
    Dim fso,strFolderName
    Set fso = WSH.CreateObject("Scripting.FileSystemObject")
    strFolderName = GetOpenDirectory("选择要搜索的目录")
    If strFolderName="" Or (Not fso.FolderExists(strFolderName)) Then
        WSH.Echo "未选择查找目录或者选择无效"
    Else
 
        Do
          SearchLists = InputBox("输入要查找的文本字符串",_
            "WORD EXCEL 搜索工具", "")
          If SearchLists="" Then
            If MsgBox("需要填入要搜索的文本，重新填写吗？",_
            vbOKCancel, "") = VbCancel Then
              Exit Sub
            End If
          End If
        Loop Until SearchLists<>""
        Lookup strFolderName
 
        WSH.Echo "搜索完毕！"
    End If
    Set fso = Nothing
End Sub
 
Function GetOpenDirectory(title)
    Const SHELL_MY_COMPUTER = &H11
    Const SHELL_WINDOW_HANDLE = 0
    Const SHELL_OPTIONS = 0
    Dim ShlApp,ShlFdr,ShlFdrItem
 
    Set ShlApp = WSH.CreateObject("Shell.Application")
    Set ShlFdr = ShlApp.Namespace(SHELL_MY_COMPUTER)
    Set ShlFdrItem = ShlFdr.Self
    GetOpenDirectory = ShlFdrItem.Path
    Set ShlFdrItem = Nothing
    Set ShlFdr = Nothing
 
    Set ShlFdr = ShlApp.BrowseForFolder _
                (SHELL_WINDOW_HANDLE, _
                title, _
                SHELL_OPTIONS, _
                GetOpenDirectory)
    If ShlFdr Is Nothing Then
        GetOpenDirectory = ""
    Else
        Set ShlFdrItem = ShlFdr.Self
        GetOpenDirectory = ShlFdrItem.Path
        Set ShlFdrItem = Nothing
    End If
    Set ShlApp = Nothing
End Function
 
Class FileOperation
 
    Private AxFile   
    Private Sub Class_Initialize()
        Set AxFile = WSH.CreateObject("Scripting.FileSystemObject")
    End Sub
 
    Private Sub Class_Terminate()
        Set AxFile = Nothing
    End Sub
 
    Private Function GetSubFolders(strFolder)
        If AxFile.FolderExists(strFolder) Then
            Dim oFolders
            Set oFolders = AxFile.GetFolder(strFolder)
            Set GetSubFolders = oFolders.SubFolders
            Set oFolders = Nothing
        Else
            Set GetSubFolders = Nothing
        End If
    End Function
 
    Private Function GetSubFiles(strFolder)
        If AxFile.FolderExists(strFolder) Then
            Dim oFolders
            Set oFolders = AxFile.GetFolder(strFolder)
            Set GetSubFiles = oFolders.Files
            Set oFolders = Nothing
        Else
            Set GetSubFiles = Null
        End If
    End Function
 
    Public Function EnumFiles(strFolder, fCallBackName, Recursion, Param)
        EnumFiles = True
        If Not AxFile.FolderExists(strFolder) Then
            EnumFiles = False
            Exit Function
        End If
 
        Dim fCallBack
        Dim SubFiles, SubFile, SubFolders, SubFolder
 
        Set fCallBack = GetRef(fCallBackName)
 
        If TypeName(strFolder) = "Folder" Then
            Set SubFiles = strFolder.Files
        Else
            Set SubFiles = GetSubFiles(strFolder)
        End If
        For Each SubFile In SubFiles
            If fCallBack(Me, AxFile, SubFile, Param) Then Exit For
        Next
        Set SubFiles = Nothing
 
        If Recursion Then
        Set SubFolders = GetSubFolders(strFolder)
            For Each SubFolder In SubFolders
                Call EnumFiles(AxFile.GetAbsolutePathName(SubFolder), _
                                  fCallBackName, Recursion, Param)
            Next
            Set SubFolders = Nothing
        End If
 
        Set fCallBack = Nothing
    End Function
 
    Public Function EnumFolders(strFolder, fCallBackName, Recursion, Param)
        EnumFolders = True
        If Not AxFile.FolderExists(strFolder) Then
            EnumFolders = False
            Exit Function
        End If
 
        Dim fCallBack
        Dim SubFolders, SubFolder, ChildFolders, ChildFolder
 
        Set fCallBack = GetRef(fCallBackName)
 
        Set SubFolders = GetSubFolders(strFolder)
            For Each SubFolder In SubFolders
                If fCallBack(Me, AxFile, SubFolder, Param) Then Exit For
 
                If Recursion Then
                    Set ChildFolders = SubFolder.SubFolders
                    For Each ChildFolder In ChildFolders
                        If fCallBack(Me, AxFile, ChildFolder, Param) Then Exit For
                        Call EnumFolders(AxFile.GetAbsolutePathName(ChildFolder), _
                                  fCallBackName, Recursion, Param)
                    Next
                    Set ChildFolders = Nothing
                End If
            Next
        Set SubFolders = Nothing
 
 
        Set fCallBack = Nothing
    End Function
End Class
 
VBMain
WSH.Quit

建议采用CScript运行上述代码以获得最佳体验，或者你可以下载 批量搜索Word或者Excel包含文字 (下载757) 。

《VBA/VBScript批量搜索多个Word或者Excel指定的包含文字》有4个想法

    1. 这个是为Windows XP + Office 2003环境下Word设计的，不包含搜索文本文档，对于更高版本的Word(*.docx)，你可以尝试将101~106行改为如下

      101
102
103
104
105
106

      Select Case UCase(fso.GetExtensionName(file.Name))
    Case "DOC", "DOCX"
        ObjectIndex = DOCUMENTS_FINDER
    Case "XLS"
        ObjectIndex = WORKBOOKS_FINDER
End Select

      对于TXT的搜索，建议使用FileSeek这款软件。

      回复

发表评论

电子邮件地址不会被公开。 必填项已用*标注

CAPTCHA

*

此站点使用Akismet来减少垃圾评论。了解我们如何处理您的评论数据。