作者：绿色风
分类：
时间：2022-08-17
浏览：226
楼主
kevinchengcw |
Q: 如何用vba代码查找当前工作簿目录下含有关键字的文件信息并列表显示？
A: 示例代码如下：
- Sub test()
- Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, Str$, Rng As Range, Str2$
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目，用于存储找到的信息
- Str = InputBox("查找内容:", "输入") '输入要查找的关键字并赋值给变量
- If Str = "" Then Exit Sub '如果未输入或取消则退出程序
- Application.ScreenUpdating = False '关闭屏幕刷新，提高处理速度
- On Error Resume Next '加上容错代码，防止运行出错
- FN = Dir(ThisWorkbook.Path & "\*.xls*") '查找当前工作簿目录下的excel文件
- Do While FN <> "" '当文件名不为空时循环执行
- If FN <> ThisWorkbook.Name Then '当文件名不为当前工作簿名时执行下述操作
- Set Wb = GetObject(ThisWorkbook.Path & "\" & FN) '打开当前文件并赋值给变量
- With Wb
- For Each Ws In .Worksheets '循环当前工作簿中各个工作表
- With Ws
- If WorksheetFunction.CountIf(.UsedRange, "*" & Str & "*") <> 0 Then '判断当前工作表中是否有关键字存在，如果有，则执行下述操作
- Set Rng = .UsedRange.Find(Str) '设定单元格区域变量为使用区域中找到的第一个单元格
- Do
- Str2 = Wb.Name & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value '将需要记录的内容串接并赋值给字符串
- If Not Dic.exists(Str2) Then Dic.Add Str2, "" '如果字典中不存在这一字符串索引及添加（主要是防止意外出错）
- Set Rng = .UsedRange.Find(Str, Rng) '单元格变量转到下一个
- Loop While .UsedRange.Find(Str).Address <> Rng.Address '如果单元格地址等于第一个找到的单元格地址时说明已经循环一遍了，所以退出循环
- End If
- End With
- Next Ws
- End With
- Wb.Close False '关闭文件且不保存
- End If
- FN = Dir '循环到下一个文件
- Loop
- Set Wb = Nothing '清空工作表变量
- With Worksheets("查询")
- .Rows("3:" & .Rows.Count).Clear '查询表里清空原有内容
- If Dic.Count > 0 Then '如果字典项目不为空，则
- Arr = Dic.keys '将keys赋值给数组
- For N = LBound(Arr) To UBound(Arr) '循环数组各项
- .Cells(N + 3, 1) = N + 1 'A列写入序号
- .Cells(N + 3, 2).Resize(1, 4) = Split(Arr(N), vbTab) '对应列写入对应内容
- Next N
- .[a3].Resize(N, 5).Borders.LineStyle = 1 '添加边框线
- MsgBox "查找完成" '显示提示信息
- Else
- MsgBox "不存在你要搜索的内容" '如果字典内容为空则直接提示内容
- End If
- End With
- Set Dic = Nothing '清空字典项目
- Application.ScreenUpdating = True '打开屏幕刷新
- End Sub
注意，上述代码对复杂数据文件无效，如：含有密码或自动运行宏及窗体等的文件，可能造成运行失败。
附示例文件。
 查找当前工作簿目录下的含有关键字的文件并列表显示.rar
|
2楼
wangzhongtu |
程序很经典谢谢 |
3楼
zixuan2119 |
追随巨人的脚步…… |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一