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)) <= 90) Or (Asc(Mid(findText, i, 1)) >= 97 And Asc(Mid(findText, i, 1)) <= 122) Then
             FindParten2 = 0 '大小写区分
        Else
             FindParten2 = 1  '大小写不区分
        End If
    Next i
    
   
Else
   FindParten2 = 1  '大小字区分しない
End If

If Sheet1.Shapes.Item(3).OLEFormat.Object.Value = 1 Then '是否是单元格一致搜索
    FindParten1 = True

Else
    FindParten1 = False
End If
 

    
    If Sheet1.Cells(5, 4) <> "" Then         '判断搜索的文件列表里是否有文件
 
            Set Rng = Range("D:D").Find("*", after:=Range("D2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            'MsgBox Rng.Row
            Range("D5:" & "D" & Rng.Row).Clear  '清空上一次文件搜索结果
            
            Set Rng = Range("F:F").Find("*", after:=Range("F2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            Range("F5:" & "F" & Rng.Row).Clear         '清空上一次文件搜索内容
            
            
    End If

            
starNum = 4
Sheet1.Cells(4, 4) = "检索中。。。"

errNum = 0
For i = 1 To filesNum

    If Sheet1.Cells(4 + i, 2) <> "" Then
        Filenames = Sheet1.Cells(4 + i, 2)
       
        Application.DisplayAlerts = False
        On Error Resume Next
        Application.Workbooks.Open filesPath & Filenames, UpdateLinks:=0 '关闭安全链接警告
        '验证文件是否有错误
        If Err.Number > 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 <= 4 Then
        clearRows = 5
    End If
    
    Range("F5:" & "F" & clearRows).Clear
    
    If Sheet1.Cells(5, 4) <> "" Then        '检查是否有搜索结果
            
    Else
        MsgBox "没有发现要文本替换的文件，请先进行检索"
        Exit Sub
    End If

            
starNum = 4
errNum = 0
For i = 1 To filesNum

    If Sheet1.Cells(4 + i, 2) <> "" Then
        Filenames = Sheet1.Cells(4 + i, 2)

        Application.DisplayAlerts = False
        On Error Resume Next
        Application.Workbooks.Open filesPath & Filenames'打开选定文件
        "验证文件是否有错误
        If Err.Number > 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

        '上边代码和代码2中的搜索功能基本相同
            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
                            Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c) = Replace(Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c), FindText, changeText, 1, , FindParten2)        '替换单元格中所含文本
                            Sheet1.Cells(starNum, 6) = Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c)
                       End If
                   
                   Else
                       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
                             Workbooks(Filenames).Worksheets(sheetNames).Cells(r, c) = changeText

'替换单元格的文本
                       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:=True
        
        
    End If
Next i

MsgBox starNum - 4  - errNum & "条单元格被替换"
  
End Sub

Sheet1示意图

	A	B	C	D	E	F
1						输入检索文本
2		点击此处选择文件夹（执行代码1）	显示选定的文件数	检索按键（绑定代码2），大小写区分勾选框1	绑定勾选框1
3		显示选定的路径		替换按键（绑定代码3），全文匹配搜索勾选框2	绑定勾选框2
4		选定的结果如下		发现文件数		输入替换文本
5		以下为选定的文件列表		以下为搜索和替换的文件表格单元格的结果列表：文件名.表格名.单元格地址		以下为搜索和替换的单元格

指定单元格查找：

Sub CellFind()
Dim Filenames
Dim sheetNames
Dim FindParten2 '攋婞
Dim FindParten1  '攋婞
Dim cellName
filesNum = Sheet1.Cells(2, 3)
filesPath = Sheet1.Cells(3, 2)
findText = Sheet1.Cells(1, 6)
'FindParten1 = Sheet1.Cells(3, 5)
cellName = StrConv(Replace(Sheet1.Cells(2, 9), " ", ""), vbNarrow)

Dim iA As Integer
If cellName = "" Or Len(cellName) < 2 Then
    MsgBox "Please input Cell Address "
    Exit Sub
Else
    iA = Asc(Left(cellName, 1))
    If Not (iA >= 65 And iA <= 90) Or (iA >= 97 And iA <= 122) Then
        MsgBox "Cell Address is bad,Please input Cell Address"
        Exit Sub
    End If
   If Not IsNumeric(Right(cellName, 1)) Then
        MsgBox "Cell Address is bad,Please input Cell Address "
        Exit Sub
   End If
End If
    
    If Sheet1.Cells(5, 4) <> "" Then
 
            Set rng = Range("D:D").Find("*", after:=Range("D2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            'MsgBox Rng.Row
            Range("D5:" & "D" & rng.Row).ClearContents
            
            Set rng = Range("F:F").Find("*", after:=Range("F2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            Range("F5:" & "F" & rng.Row).Clear
            
            
    End If

            
starNum = 4
Sheet1.Cells(4, 4) = "Searching......."
errNum = 0
For i = 1 To filesNum

    If Sheet1.Cells(4 + i, 2) <> "" Then
        Filenames = Sheet1.Cells(4 + i, 2)
        
        Application.DisplayAlerts = False
        On Error Resume Next
        Application.Workbooks.Open filesPath & Filenames, UpdateLinks:=0
        
       
        
        ThisWorkbook.Activate
        
         
         For j = 1 To Workbooks(Filenames).Sheets.count
         Dim values
            sheetNames = Workbooks(Filenames).Sheets(j).Name
            starNum = starNum + 1
            values = Workbooks(Filenames).Worksheets(sheetNames).Range(cellName).Value
            If values = "" Then
                values = "Empty"
            End If
            Sheet1.Cells(starNum, 6) = values
            Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & cellName
            Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress
           
        Next j
        
        Workbooks(Filenames).Close Savechanges:=False
        

    End If
     Application.DisplayAlerts = True
Next i

If starNum = 4 Then
Sheet1.Cells(4, 4) = "Nothing Find "
Else
Sheet1.Cells(4, 4) = starNum - 4 - errNum & " finded"
End If
  Cells(4, 4).Select

End Sub
 

给指定单元格赋值

Sub CellSet()
Dim Filenames
Dim sheetNames
Dim FindParten2 '攋婞
Dim FindParten1  '攋婞
Dim cellName
filesNum = Sheet1.Cells(2, 3)
filesPath = Sheet1.Cells(3, 2)
findText = Sheet1.Cells(1, 6)
'FindParten1 = Sheet1.Cells(3, 5)
cellName = StrConv(Replace(Sheet1.Cells(2, 9), " ", ""), vbNarrow)
 Dim values
 values = Sheet1.Cells(2, 11)
Dim iA As Integer
If cellName = "" Or Len(cellName) < 2 Then
    MsgBox "Please input Cell Address "
    Exit Sub
Else
    iA = Asc(Left(cellName, 1))
    If Not (iA >= 65 And iA <= 90) Or (iA >= 97 And iA <= 122) Then
        MsgBox "Cell Address is bad,Please input Cell Address "
        Exit Sub
    End If
   If Not IsNumeric(Right(cellName, 1)) Then
        MsgBox "Cell Address is bad,Please input Cell Address "
        Exit Sub
   End If
End If
    
    If Sheet1.Cells(5, 4) <> "" Then
 
            Set rng = Range("D:D").Find("*", after:=Range("D2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            'MsgBox Rng.Row
            Range("D5:" & "D" & rng.Row).ClearContents
            
            Set rng = Range("F:F").Find("*", after:=Range("F2000"), searchorder:=xlByColumns, searchdirection:=xlPrevious)
            Range("F5:" & "F" & rng.Row).Clear
            
            
    End If

            
starNum = 4
Sheet1.Cells(4, 4) = "Searching......."
errNum = 0
For i = 1 To filesNum

    If Sheet1.Cells(4 + i, 2) <> "" Then
        Filenames = Sheet1.Cells(4 + i, 2)
        
        Application.DisplayAlerts = False
        On Error Resume Next
        Application.Workbooks.Open filesPath & Filenames, UpdateLinks:=0
        
       
        
        ThisWorkbook.Activate
        
         
         For j = 1 To Workbooks(Filenames).Sheets.count
        
            sheetNames = Workbooks(Filenames).Sheets(j).Name
            starNum = starNum + 1
            Workbooks(Filenames).Worksheets(sheetNames).Range(cellName).Value = values
             
           
            Sheet1.Cells(starNum, 6) = values
            Sheet1.Cells(starNum, 4) = Filenames & "." & sheetNames & "." & cellName
            Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(starNum, 4), Address:=filesPath & Filenames, SubAddress:=sheetNames & "!" & celladress
           
        Next j
        
        Workbooks(Filenames).Close Savechanges:=True
        

    End If
     Application.DisplayAlerts = True
Next i

If starNum = 4 Then
Sheet1.Cells(4, 4) = "Nothing Find "
Else
Sheet1.Cells(4, 4) = starNum - 4 - errNum & " finded "
End If
  Cells(4, 4).Select
End Sub