VBA实现多个EXCEL文件的文本检索和文本替换功能

发现系统批量搜索Excel中的文字不好用，替换更无从谈起，于是利用VBA自己搞。

1、点击固定一个单元格，激发对话框打开事件，选定要搜索的文件夹。

2、选定后自动在该单元格下列出文件夹路径，和文件列表同时加载超级链接。还有文件个数。每次选定将清空该列表和文件夹路径等信息。

3、新建一个实心矩形作为搜索按键，并添加至宏进行文本搜索功能代码的编辑。

        搜索是根据文件夹列表和文件夹路径逐一打开Excel文件，对检索的文本进行搜索并记录和加载超级链接，该链接定位到单元格。将加载超级链接的搜索结果列在下方，同时设置两个勾选选框一个是"大小写区别查找"，一个是“全文匹配查找”。

4、新建一个实心矩形作为替换按键，并添加至宏进行文本替换功能代码的编辑。

代码1：

单击某单元格，激活一个对话框进行文件夹选定。

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$B$2" Then '被点击的单元格，触发以下事件    With Application.FileDialog(msoFileDialogFolderPicker)'打开对话框             If .Show = -1 Then             MsgBox "选择的文件路径是：" + .SelectedItems(1), vbOKOnly + vbInformation, "消息提示"             Sheet1.Cells(3, 2) = .SelectedItems(1) & "\" '保存文件路径                          Set Rng = Range("B:B").Find("*", after:=Range("B2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)                          Range(Rows(5), Rows(Rng.Row)).Delete        '清空上一次文件列表

             Dim MyFile As String                 Dim s As String                 Dim count As Integer                 MyFile = Dir(.SelectedItems(1) & "\*.xlsx")                 count = count + 1

        '加载该文件夹下的Excel文件名

                Sheet1.Cells(4 + count, 2) = Replace(MyFile, .SelectedItems(1), "")                 Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(4 + count, 2), Address:=.SelectedItems(1) & "\" & MyFile

  '加载第一行文件                 's = s & count & "、" & MyFile                Do While MyFile ""                     MyFile = Dir                     If MyFile = "" Then                         Exit Do                     End If                     count = count + 1                    Sheet1.Cells(4 + count, 2) = Replace(MyFile, .SelectedItems(1), "")

'加载其余第多行文件                    Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(4 + count, 2), Address:=.SelectedItems(1) & "\" & MyFile                 Loop              Set Rng = Range("B:C").Find("*", after:=Range("B200"), searchorder:=xlByColumns, searchdirection:=xlPrevious)             Sheet1.Cells(2, 3) = Rng.Row - 4        '获取加载条数

        End If     End With End If 代码2：

搜索部分

Sub 检索启动() Dim Filenames Dim sheetNames Dim FindParten2 Dim FindParten1

filesNum = Sheet1.Cells(2, 3)           '获取文件加载条数 filesPath = Sheet1.Cells(3, 2)         '获取文件夹路径 FindText = Sheet1.Cells(1, 6)         '获取要搜索的字符 FindParten1 = Sheet1.Cells(3, 5)          '获取是否要全文匹配单元格搜索

'页面添加控件，item2，item3，分别控制大小写区分和是否全文匹配搜索

If Sheet1.Shapes.Item(2).OLEFormat.Object.Value = 1 Then '获取是否要大小写区分搜索          For i = 1 To Len(findText)         If (Asc(Mid(findText, i, 1)) >= 65 And Asc(Mid(findText, i, 1)) = 97 And Asc(Mid(findText, i, 1)) 0 Then             starNum = starNum + 1             Sheet1.Cells(starNum, 4) = Filenames & "文件无法正常打开。"         GoTo 100         End If                  ThisWorkbook.Activate         '焦点返回当前打开的文件                             For j = 1 To Workbooks(Filenames).Sheets.count           '获取当前文件中表格的个数，并逐一打开进行搜索             sheetNames = Workbooks(Filenames).Sheets(j).Name             Dim rn As Long, cn As Long             Dim celladress                       rn = Workbooks(Filenames).Worksheets(sheetNames).Cells.Find("*", Workbooks(Filenames).Worksheets(sheetNames).Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious).Row         '获取最大行数             cn = Workbooks(Filenames).Worksheets(sheetNames).UsedRange.Columns.count         '获取最大列数           

 '逐行逐列搜索             For r = 1 To rn                  For c = 1 To cn

If IsError(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)) = False Then

'处理错误单元格                         '常量       号码     表示                         'xlErrDiv0        2007        #DIV/0!                         'xlErrNA         2042        #N/A                         'xlErrName        2029        #NAME?                         'xlErrNull        2000        #NULL!                         'xlErrNum        2036         #NUM!                         'xlErrRef        2023        #REF!                         'xlErrValue        2015        #VALUE!                    If FindParten1 = False Then                                            If InStr(1, Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c), FindText, FindParten2) > 0 Then                '搜索包含查找文本的单元格，判断是否含有字符，并代入大小写区分选项的参数。                            starNum = starNum + 1                            celladress = Replace(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c).Address, "$", "")                '获取单元格地址                            Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & celladress                            '将结果所在的文件和表格已及单元格写入列表

Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress

                                '并加载超级链接定位到所在文件表格的单元格                             Sheet1.Cells(starNum, 6) = Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)

                                '将搜索到的单元格内容写入列表                        End If                                        Else

 If FindParten2 = 0 Then '大小写区分选项                                     If Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c) = findText Then                                          starNum = starNum + 1                                          celladress = Replace(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c).Address, "$", "")                                                                                    Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & celladress                                                                                    Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress                                          Sheet1.Cells(starNum, 6) = Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)                                     End If                                 Else        ’不区分大小写                                                                          If LCase(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)) = LCase(findText) Then                                                  starNum = starNum + 1                                          celladress = Replace(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c).Address, "$", "")                                                                                    Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & celladress                                                                                    Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress                                          Sheet1.Cells(starNum, 6) = Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)        '将结果所在的文件和表格已及单元格写入列表并加载超级链接                                     End If                                                                      End If

End If

 Else                   '处理错误单元格                     starNum = starNum + 1                     celladress = Replace(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c).Address, "$", "")                     Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & celladress                     Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress                     Sheet1.Cells(starNum, 6) = "该值有错误"                     Sheet1.Cells(starNum, 6).Font.Color = vbRed                     errNum = errNum + 1                     End If                  Next c             Next r          Cells(starNum, 4).Select        '焦点回到当前文件         Next j                  Workbooks(Filenames).Close Savechanges:=False         '关闭搜索的文件             100:     End If      Application.DisplayAlerts = True Next i

If starNum = 4 Then        '提示搜索结果 Sheet1.Cells(4, 4) = "没有发现结果" Else Sheet1.Cells(4, 4) = starNum - 4 - errNum & "条结果" End If   Cells(4, 4).Select End Sub

代码3：

替换部分

Sub 启动替换()

Dim Filenames Dim sheetNames Dim FindParten2 Dim FindParten1

changeText = Sheet1.Cells(4, 6)        '替换的文本

filesNum = Sheet1.Cells(2, 3)           '获取文件加载条数 filesPath = Sheet1.Cells(3, 2)         '获取文件夹路径 FindText = Sheet1.Cells(1, 6)         '获取要搜索的字符 FindParten1 = Sheet1.Cells(3, 5)          '获取是否要全文匹配单元格搜索

If Sheet1.Cells(3, 4) = True Then           '获取是否要大小写区分     FindParten2 = vbTextCompare Else     FindParten2 = vbBinaryCompare End If

     '清空上次替换的结果     Set Rng = Range("F:F").Find("*", after:=Range("F2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)     clearRows = Rng.Row          If clearRows