设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › VBA搜索文件夹
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 966|回复: 9

[已解决]VBA搜索文件夹

[复制链接]
发表于 2022-1-5 20:31 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
电脑中有很多文件，每次都需要打开依次打开路径统计文件数量，麻烦各位老师帮忙写个VBA代码 搜狗截图20220105203056.png

最佳答案
月排行榜 / 总排行榜
林木水
2022-1-7 12:21
  1. Sub filesearch()
  2. Dim i As Long
  3. Dim arr()
  4. Dim brr()
  5. ActiveSheet.Range("b8:e65535").ClearContents
  6. With Application.filesearch
  7.     .NewSearch
  8.     .LookIn = ActiveSheet.Range("b5").Value
  9.     .SearchSubFolders = True
  10.     .Filename = ActiveSheet.Range("c1").Value & ActiveSheet.Range("c2").Value & ActiveSheet.Range("c3").Value
  11.     If .Execute() > 0 Then
  12.         ReDim arr(1 To .FoundFiles.Count, 1 To 1)
  13.         For i = 1 To .FoundFiles.Count
  14.             arr(i, 1) = .FoundFiles(i)
  15.         Next i
  16.     End If
  17. End With
  18. ReDim brr(1 To UBound(arr, 1), 1 To 4)
  19. For i = 1 To UBound(arr, 1)
  20.     brr(i, 1) = Mid(arr(i, 1), 1, VBA.InStrRev(arr(i, 1), "") - 1)
  21.     brr(i, 2) = Dir(arr(i, 1))
  22.     If VBA.InStr(brr(i, 2), ThisWorkbook.Name) Then
  23.         brr(i, 2) = VBA.Replace(Dir(arr(i, 1)), "~$", "")
  24.         arr(i, 1) = VBA.Replace(arr(i, 1), "~$", "")
  25.     End If
  26.     brr(i, 3) = VBA.FileDateTime(arr(i, 1))
  27.     brr(i, 4) = Round(VBA.FileLen(arr(i, 1)) / 1000, 2) & "kb"
  28. Next i
  29. ActiveSheet.Range("b8").Resize(UBound(arr, 1), 4) = brr
  30. For i = 1 To UBound(arr, 1)
  31.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 0), brr(i, 1)
  32.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 1), arr(i, 1)
  33. Next i
  34. End Sub
复制代码
代码修改了一下。附件查看。

不知道怎么回事昨天晚上的代码不一样了，还有附件也没看到。

特别要注意的是最开始的目录信息要放准确了。还有关键内容需要填写一下，不查询就填 *，格式就是.*

搜索.rar

42.92 KB, 下载次数: 17
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2022-1-6 18:32 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
这个应该也不难，我需要回去看一下代码。遍历文件夹跟遍历文件就可以做到
回复

使用道具 举报

发表于 2022-1-6 22:19 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 林木水 于 2022-1-6 22:22 编辑

新鲜出炉了，请注意查收，是否ok，思路:
1.使用WPS的filesearch函数,提取所有文件路径到数组arr
2.将数组arr分成文件夹和文件名、内存大小、修改时间四部分存入数组brr

3.使用工作表Hyperlinks.Add方法添加超链接也就是brr（,1）brr(,2)

4.注意事项：
  1）当前文件打开的需要处理以下~$前缀，否则当前文件的超链接会出错
  2）读取内存vba.filelen 读取字节个数除以1000就是kb
  3）读取内存修改日期，vba.filedatetime

5.当然问题解决了，要给什么？

复制代码
  1. Sub filesearch()
  2. Dim i As Long
  3. Dim arr()
  4. ActiveSheet.Range("b8:e65535").ClearContents
  5. With Application.filesearch
  6.     .NewSearch
  7.     .LookIn = ActiveSheet.Range("b5").Value
  8. '    .LookIn = "C:\Users\Acer\Desktop\搜索"
  9.     .SearchSubFolders = True
  10.     .Filename = ActiveSheet.Range("c1").Value & ActiveSheet.Range("c2").Value & ActiveSheet.Range("c3").Value
  11.     If .Execute() > 0 Then
  12.         ReDim arr(1 To .FoundFiles.Count, 1 To 1)
  13.         For i = 1 To .FoundFiles.Count
  14.             arr(i, 1) = .FoundFiles(i)
  15.         Next i
  16.     End If
  17. End With
  18. ReDim brr(1 To UBound(arr, 1), 1 To 4)
  19. For i = 1 To UBound(arr, 1)
  20.     brr(i, 1) = Mid(arr(i, 1), 1, VBA.InStrRev(arr(i, 1), "") - 1)
  21.     brr(i, 2) = Mid(arr(i, 1), VBA.InStrRev(arr(i, 1), "") + 1, Len(arr(i, 1)))
  22.     If VBA.InStr(brr(i, 2), ThisWorkbook.Name) Then
  23.         brr(i, 2) = VBA.Replace(brr(i, 2), "~$", "")
  24.         arr(i, 1) = VBA.Replace(arr(i, 1), "~$", "")
  25.     End If
  26.     brr(i, 3) = VBA.FileDateTime(arr(i, 1))
  27.     brr(i, 4) = Round(VBA.FileLen(arr(i, 1)) / 1000, 2) & "kb"
  28. Next i
  29. ActiveSheet.Range("b8").Resize(UBound(arr, 1), 4) = brr
  30. For i = 1 To UBound(arr, 1)
  31.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 0), brr(i, 1)
  32.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 1), brr(i, 2)
  33. Next i
  34. End Sub
复制代码



回复

使用道具 举报

发表于 2022-1-7 08:07 | 显示全部楼层
雙擊連結檔案，請測試看看，謝謝

搜索.zip

75.66 KB, 下载次数: 3

评分

参与人数 1学分 +2 收起 理由
楚雪飞扬 + 2 学习了

查看全部评分

回复

使用道具 举报

发表于 2022-1-7 12:21 | 显示全部楼层    本楼为最佳答案   
  1. Sub filesearch()
  2. Dim i As Long
  3. Dim arr()
  4. Dim brr()
  5. ActiveSheet.Range("b8:e65535").ClearContents
  6. With Application.filesearch
  7.     .NewSearch
  8.     .LookIn = ActiveSheet.Range("b5").Value
  9.     .SearchSubFolders = True
  10.     .Filename = ActiveSheet.Range("c1").Value & ActiveSheet.Range("c2").Value & ActiveSheet.Range("c3").Value
  11.     If .Execute() > 0 Then
  12.         ReDim arr(1 To .FoundFiles.Count, 1 To 1)
  13.         For i = 1 To .FoundFiles.Count
  14.             arr(i, 1) = .FoundFiles(i)
  15.         Next i
  16.     End If
  17. End With
  18. ReDim brr(1 To UBound(arr, 1), 1 To 4)
  19. For i = 1 To UBound(arr, 1)
  20.     brr(i, 1) = Mid(arr(i, 1), 1, VBA.InStrRev(arr(i, 1), "") - 1)
  21.     brr(i, 2) = Dir(arr(i, 1))
  22.     If VBA.InStr(brr(i, 2), ThisWorkbook.Name) Then
  23.         brr(i, 2) = VBA.Replace(Dir(arr(i, 1)), "~$", "")
  24.         arr(i, 1) = VBA.Replace(arr(i, 1), "~$", "")
  25.     End If
  26.     brr(i, 3) = VBA.FileDateTime(arr(i, 1))
  27.     brr(i, 4) = Round(VBA.FileLen(arr(i, 1)) / 1000, 2) & "kb"
  28. Next i
  29. ActiveSheet.Range("b8").Resize(UBound(arr, 1), 4) = brr
  30. For i = 1 To UBound(arr, 1)
  31.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 0), brr(i, 1)
  32.     Sheet3.Hyperlinks.Add Range("b8").Offset(i - 1, 1), arr(i, 1)
  33. Next i
  34. End Sub
复制代码
代码修改了一下。附件查看。

不知道怎么回事昨天晚上的代码不一样了，还有附件也没看到。

特别要注意的是最开始的目录信息要放准确了。还有关键内容需要填写一下，不查询就填 *，格式就是.*

搜索.rar

54.86 KB, 下载次数: 7
回复

使用道具 举报

 楼主| 发表于 2022-1-12 21:37 | 显示全部楼层
sam-wang 发表于 2022-1-7 08:07
雙擊連結檔案，請測試看看，謝謝

老师好，我按您提供的代码实际运行了下，黄色区域不能按关键字进行查找，
还有一个问题就是，按条件进行查询，当查找到满足文件时，能否自动打开文件并复制内容到另一个工作表中，
搜狗截图20220112213145.png

回复

使用道具 举报

发表于 2022-1-13 11:40 | 显示全部楼层
楚雪飞扬 发表于 2022-1-12 21:37
老师好，我按您提供的代码实际运行了下，黄色区域不能按关键字进行查找，
还有一个问题就是，按条件进行 ...

請測試看看，謝謝

搜索.zip

113.52 KB, 下载次数: 5
回复

使用道具 举报

 楼主| 发表于 2022-1-13 13:38 | 显示全部楼层
sam-wang 发表于 2022-1-13 11:40
請測試看看，謝謝

能否将当查找到满足文件时，自动按日期依次打开文件并复制内容到另一个工作表中(每个文件格式一样）复制文件内容时，只保留第一个文件的表头
回复

使用道具 举报

发表于 2022-1-13 14:18 | 显示全部楼层
楚雪飞扬 发表于 2022-1-13 13:38
能否将当查找到满足文件时，自动按日期依次打开文件并复制内容到另一个工作表中(每个文件格式一样）复制 ...

自动按日期依次打开文件并复制内容到另一个工作表中(每个文件格式一样）复制文件内容时，只保留第一个文件的表头
>>需要再釐清需求如下，謝謝
1. 自动按日期依次打开，>> 這是什麼意思??
2. 打开文件并复制内容到另一个工作表中(每个文件格式一样）复制文件内容时 >> 因為看到您有另發一個詢問，附件檔案有很多工作表，要複製哪個工作表? 複製後要關閉檔案嗎?
复制内容到另一个工作表中，是指"搜索"工作表嗎?

3. 只保留第一个文件的表头 >> 是指複製第1列表頭至"搜索"工作表嗎?


回复

使用道具 举报

 楼主| 发表于 2022-1-13 15:28 | 显示全部楼层
sam-wang 发表于 2022-1-13 14:18
自动按日期依次打开文件并复制内容到另一个工作表中(每个文件格式一样）复制文件内容时，只保留第一个文 ...

老师您好，我这边把需求及逻辑重新整理了下，麻烦您 抽空看下！
需求：根据查找路径范围，可按关键字搜索查找文件并打开
1.查询条件（文件类，文件类型）：可按关键字进行查找，当不使用关键字时可放空或用*号代替（模拟查询方式，见图片）
2.查询条件（访问日期）：可按从起始日期至截止日期查找之间范围的数据，当不使用日期搜索时可放空或用*号代替（模拟查询方式，见图片）
3.将当查找到满足文件时，按访问日期依次复制文件内容到另一个工作表《数据源表》(注：每个文件格式都一样）复制文件内容时，只保留第一个文件的表头，复制其它文件从第二列开始复制！
4.序号：将当前格式改为数值格式


搜狗截图20220113152745.png

综合各类早报.rar

35.98 KB, 下载次数: 2
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-11 01:47 , Processed in 0.318810 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表