Excelのvbaを使って、文字列を検索する
' ========================================
' 模块名称：SearchExcelTool_Optimized
' 功能：创建搜索界面并执行跨Excel文件内容搜索
' 作者：Qwen
' 优化要点：
' - 使用 .Find 提升搜索效率
' - 增强错误处理
' - 添加超链接支持
' - 自动适配长路径
' - 模块化设计
' ========================================
Option Explicit
' ================================
' 自动运行宏：打开工作簿时初始化界面
' ================================
Sub Auto_Open()
Call 初始化搜索界面
End Sub
' ================================
' 初始化搜索界面
' ================================
Sub 初始化搜索界面()
Dim ws As Worksheet
Dim btn As Button
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' 获取或创建"搜索工具"工作表
Set ws = ThisWorkbook.Worksheets("搜索工具")
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
ws.name = "搜索工具"
Else
ws.Cells.Clear
DeleteAllShapes ws ' 清除所有按钮和图形对象
End If
' 设置页面布局
With ws
.Columns("A").ColumnWidth = 2
.Columns("B:F").ColumnWidth = 15
.Rows("5:5").RowHeight = 25
.Rows("9:9").RowHeight = 25
.Range("B2:F15").Interior.Color = RGB(242, 242, 242)
End With
' 标题
With ws.Range("B2")
.Value = "Excel文件搜索工具"
.Font.Size = 20
.Font.Bold = True
.Font.Color = RGB(79, 129, 189)
End With
' 路径标签
With ws.Range("B4")
.Value = "文件夹路径："
.Font.Size = 12
.Font.Bold = True
End With
' 路径输入框
With ws.Range("B5:F5")
.MergeCells = True
.Value = "C:\"
.Font.Size = 11
.Interior.Color = vbWhite
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
' 注意：命名范围需唯一，防止重复定义
AddNamedRange ThisWorkbook, "文件夹路径输入框", ws.Range("B5")
' 提示文字
With ws.Range("B6")
.Value = "例如：C:\Users\用户名\Documents"
.Font.Size = 9
.Font.Color = RGB(150, 150, 150)
.Font.Italic = True
End With
' 搜索内容标签
With ws.Range("B8")
.Value = "搜索内容："
.Font.Size = 12
.Font.Bold = True
End With
' 搜索内容输入框
With ws.Range("B9:F9")
.MergeCells = True
.Value = ""
.Font.Size = 11
.Interior.Color = vbWhite
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
AddNamedRange ThisWorkbook, "搜索内容输入框", ws.Range("B9")
' 提示文字
With ws.Range("B10")
.Value = "输入要查找的文字或数字"
.Font.Size = 9
.Font.Color = RGB(150, 150, 150)
.Font.Italic = True
End With
' 搜索按钮
Set btn = ws.Buttons.Add(ws.Range("B12").Left, ws.Range("B12").Top, 150, 35)
With btn
.Text = "开始搜索"
.Font.Size = 12
.Font.Bold = True
.OnAction = "执行搜索"
End With
' 使用说明
With ws.Range("B14")
.Value = "使用说明："
.Font.Size = 11
.Font.Bold = True
.Font.Color = RGB(79, 129, 189)
End With
With ws.Range("B15")
.Value = "1. 在上方输入要搜索的文件夹路径" & vbCrLf & _
"2. 输入要查找的文字内容" & vbCrLf & _
"3. 点击'开始搜索'按钮" & vbCrLf & _
"4. 搜索结果将显示在'搜索结果'工作表中"
.Font.Size = 10
.WrapText = True
.RowHeight = 80
End With
MsgBox "搜索界面已创建！" & vbCrLf & vbCrLf & _
"请在'搜索工具'工作表中：" & vbCrLf & _
"1. 输入文件夹路径" & vbCrLf & _
"2. 输入搜索内容" & vbCrLf & _
"3. 点击'开始搜索'按钮", vbInformation, "完成"
ws.Activate
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "初始化失败：" & Err.Description, vbCritical, "错误"
Application.ScreenUpdating = True
End Sub
' ================================
' 执行搜索主逻辑（使用 .Find 替代遍历）
' ================================
Sub 执行搜索()
Dim 文件夹路径 As String
Dim 搜索文本 As String
Dim fso As Object, 文件夹 As Object, 文件 As Object
Dim wb As Workbook, ws As Worksheet
Dim rngFound As Range, FirstAddress As String
Dim 结果工作表 As Worksheet, 搜索工具表 As Worksheet
Dim 结果行 As Long
Dim 文件计数 As Long, 匹配计数 As Long
Dim StartTime As Double
StartTime = Timer ' 记录开始时间
' 获取搜索界面
Set 搜索工具表 = ThisWorkbook.Worksheets("搜索工具")
If 搜索工具表 Is Nothing Then
MsgBox "请先运行'初始化搜索界面'宏创建搜索界面", vbExclamation
Exit Sub
End If
' 获取用户输入
文件夹路径 = Trim(GetRangeValue(搜索工具表, "文件夹路径输入框"))
搜索文本 = Trim(GetRangeValue(搜索工具表, "搜索内容输入框"))
' 输入验证
If 文件夹路径 = "" Then
MsgBox "请输入文件夹路径！", vbExclamation, "提示"
Exit Sub
End If
If 搜索文本 = "" Then
MsgBox "请输入要搜索的内容！", vbExclamation, "提示"
Exit Sub
End If
' 检查文件夹是否存在
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(文件夹路径) Then
MsgBox "文件夹路径不存在，请检查路径是否正确！" & vbCrLf & _
"当前路径：" & 文件夹路径, vbExclamation, "错误"
Exit Sub
End If
' 准备结果表
Set 结果工作表 = GetOrCreateResultSheet(ThisWorkbook, "搜索结果")
If 结果工作表 Is Nothing Then Exit Sub
' 写入表头
With 结果工作表.Rows(1)
.Clear
.Value = Array("序号", "文件名", "工作表", "单元格位置", "单元格内容", "完整路径")
.Font.Bold = True
.Interior.Color = RGB(79, 129, 189)
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
结果行 = 2
文件计数 = 0
匹配计数 = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "正在搜索，请稍候..."
On Error Resume Next
Set 文件夹 = fso.GetFolder(文件夹路径)
Dim FileName As String
For Each 文件 In 文件夹.Files
FileName = LCase(文件.name)
' 判断是否为Excel文件
If Right(FileName, 5) = ".xlsx" Or _
Right(FileName, 4) = ".xls" Or _
Right(FileName, 5) = ".xlsm" Then
' 排除当前工作簿
If 文件.Path <> ThisWorkbook.FullName Then
Application.StatusBar = "正在搜索: " & 文件.name
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(文件.Path, ReadOnly:=True, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
On Error GoTo 0
If Not wb Is Nothing Then
文件计数 = 文件计数 + 1
For Each ws In wb.Worksheets
With ws.UsedRange
Set rngFound = .Find(What:=搜索文本, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False)
If Not rngFound Is Nothing Then
FirstAddress = rngFound.Address
Do
结果工作表.Cells(结果行, 1).Value = 结果行 - 1
结果工作表.Cells(结果行, 2).Value = 文件.name
结果工作表.Cells(结果行, 3).Value = ws.name
结果工作表.Cells(结果行, 4).Value = rngFound.Address
结果工作表.Cells(结果行, 5).Value = Left(rngFound.Text, 32767) ' 防止超长文本崩溃
结果工作表.Cells(结果行, 6).Value = 文件.Path
' 添加可点击的超链接（双击跳转到该文件）
结果工作表.Hyperlinks.Add _
Anchor:=结果工作表.Cells(结果行, 2), _
Address:=文件.Path, _
TextToDisplay:=文件.name
结果行 = 结果行 + 1
匹配计数 = 匹配计数 + 1
Set rngFound = .FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <> FirstAddress
End If
End With
Next ws
wb.Close SaveChanges:=False
End If
End If
End If
Next 文件
On Error GoTo 0
' 格式化结果
With 结果工作表
.Columns("A:F").AutoFit
If 结果行 > 2 Then .Range("A1:F1").AutoFilter
End With
' 恢复设置
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
' 输出结果
If 匹配计数 = 0 Then
MsgBox "未找到包含 """ & 搜索文本 & """ 的内容" & vbCrLf & _
"搜索位置：" & 文件夹路径 & vbCrLf & _
"耗时：" & Format(Timer - StartTime, "0.00") & " 秒", vbInformation, "搜索完成"
Else
结果工作表.Activate
MsgBox "搜索完成！" & vbCrLf & vbCrLf & _
"共扫描 " & 文件计数 & " 个Excel文件" & vbCrLf & _
"共找到 " & 匹配计数 & " 条匹配记录" & vbCrLf & _
"搜索内容：" & 搜索文本 & vbCrLf & _
"搜索位置：" & 文件夹路径 & vbCrLf & _
"耗时：" & Format(Timer - StartTime, "0.00") & " 秒", vbInformation, "搜索完成"
End If
End Sub
' ================================
' 辅助函数区
' ================================
' 删除指定工作表上的所有形状（按钮、图片等）
Private Sub DeleteAllShapes(ws As Worksheet)
Dim shp As Shape
For Each shp In ws.Shapes
If shp.Type <> msoGroup Then shp.Delete
Next
' 处理组合图形
On Error Resume Next
ws.Shapes.SelectAll
Selection.Delete
On Error GoTo 0
End Sub
' 安全添加命名区域（避免重复报错）
Private Sub AddNamedRange(wb As Workbook, name As String, rng As Range)
On Error Resume Next
wb.Names(name).Delete
wb.Names.Add name:=name, RefersTo:=rng
On Error GoTo 0
End Sub
' 获取命名区域的值，安全封装
Private Function GetRangeValue(ws As Worksheet, name As String) As String
On Error Resume Next
GetRangeValue = CStr(ws.Range(name).Value)
On Error GoTo 0
End Function
' 获取或创建结果工作表
Private Function GetOrCreateResultSheet(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetOrCreateResultSheet = wb.Worksheets(sheetName)
If GetOrCreateResultSheet Is Nothing Then
Set GetOrCreateResultSheet = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
GetOrCreateResultSheet.name = sheetName
Else
GetOrCreateResultSheet.Cells.Clear
End If
On Error GoTo 0
End Function