ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 小花鹿

[讨论] 小花鹿学习VBA记录

  [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-7 22:41 | 显示全部楼层
本帖最后由 小花鹿 于 2013-4-9 10:45 编辑


列出ThisWorkbook.Path及子文件夹中的文件名:
Option Explicit
Dim FileList(1 To 65536, 1 To 1), n&
Sub FolderFileList()
Dim fso, Folder, f
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(ThisWorkbook.Path)
For Each f In Folder.Files
    n = n + 1
    FileList(n, 1) = f
Next f
SubFolderFileList (ThisWorkbook.Path)
[a1].Resize(n) = FileList
n = 0
End Sub
Function SubFolderFileList(pth)
Dim fso, Folder, SubFolder, f, fd
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(pth)
Set SubFolder = Folder.subfolders
For Each fd In SubFolder
    For Each f In fd.Files
        n = n + 1
        FileList(n, 1) = f
    Next f
    SubFolderFileList (fd.Path)
Next fd
End Function



补充内容 (2014-8-27 21:49):
Sub test()
Dim fso, fld, f, br(1 To 65536, 1 To 1), n&
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(ThisWorkbook.Path)
For Each f In fld.Files
    n = n + 1
    br(n, 1) = f
Next f
Call digui(br, n, ThisWorkbook.Path)
[a1].Resize(n) = br
End Sub
Sub digui(br, n, p)
Dim fso, fld, f, subfld, fd
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(p)
Set subfld = fld.subfolders
For Each fd In subfld
    For Each f In fd.Files
        n = n + 1
        br(n, 1) = f
    Next f
    Call digui(br, n, fd)
Next fd
End Sub

查找xls文件路径名.rar

601 KB, 下载次数: 56

TA的精华主题

TA的得分主题

发表于 2013-4-7 23:03 | 显示全部楼层
本帖最后由 香川群子 于 2013-4-8 08:27 编辑

递归调试好了:

今天早上再做测试时,发现2个bug:
1. 文件夹中的文件无后缀时出错 (即不含[.]的文件)
   纠正方法是增加一个判断以便忽略错误

2. 文件后缀为大写英文字母时会被忽略
  纠正方法是统一先将后缀转换为小写字母。
  1. Dim flist$(65535, 3), fc&, k&
  2. Sub FileList()
  3.     tms = Timer
  4.    
  5.     k = 0: fc = 1
  6.     Set fso = CreateObject("Scripting.FileSystemObject")
  7.     Set fld = fso.GetFolder(ThisWorkbook.path)
  8.     For Each f In fld.Files
  9.         n = InStrRev(f.name, ".")
  10.         If n Then
  11.             x = LCase(Mid(f.name, n + 1))
  12.             If x Like "xl*" Then
  13.                 flist(k, 0) = x
  14.                 flist(k, 1) = f.name
  15.                 flist(k, 2) = fld.name
  16.                 flist(k, 3) = fld.path
  17.                 k = k + 1
  18.             End If
  19.         End If
  20.     Next
  21.     Call GetFolderFile(ThisWorkbook.path)
  22.    
  23.     [a1].CurrentRegion.Offset(1) = ""
  24.     [a2].Resize(k, 4) = flist
  25.     [b1] = "在" & fc & "个子文件夹中共找到 " & k & "个Excel文件。"
  26.     MsgBox Format(Timer - tms, "0.000s")
  27. End Sub
  28. Function GetFolderFile(pth)
  29.     Set fso = CreateObject("Scripting.FileSystemObject")
  30.     Set fld = fso.GetFolder(pth)
  31.     Set fsb = fld.SubFolders
  32.     For Each fd In fsb
  33.         For Each f In fd.Files
  34.             n = InStrRev(f.name, ".")
  35.             If n Then
  36.                 x = LCase(Mid(f.name, n + 1))
  37.                 If x Like "xl*" Then
  38.                     flist(k, 0) = x
  39.                     flist(k, 1) = f.name
  40.                     flist(k, 2) = fd.name
  41.                     flist(k, 3) = fd.path
  42.                     k = k + 1
  43.                 End If
  44.             End If
  45.         Next
  46.         fc = fc + 1: Call GetFolderFile(fd.path)
  47.     Next
  48. End Function
复制代码


GetFileList.zip (10.96 KB, 下载次数: 50)

点评

我得慢慢研究,直到自己会写为止。  发表于 2013-4-8 11:42

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-4-7 23:10 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
小花鹿 发表于 2013-4-7 22:41
我上个附件吧:
结果放在:把此目录及子目录中的所有xls文件放在此中.xls
型如:C:\Documents and Se ...

附件测试通过……

统计时,会把这个文件自身也统计进去的。呵呵。

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-7 23:30 | 显示全部楼层
香川群子 发表于 2013-4-7 23:03
递归调试好了:

我运行了一下,效果很好,但我没有认认真真的测试,等我仔细测试后,有问题再向你请教。
希望通过我们的交流能把这个代码做成一个“经典”,呵呵。
再问:递归是什么意思?
你喝酒不?敬你一杯.......................

点评

关注一下。  发表于 2013-4-8 10:49

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-7 23:39 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
香川群子 发表于 2013-4-7 23:10
附件测试通过……

统计时,会把这个文件自身也统计进去的。呵呵。

“统计时,会把这个文件自身也统计进去的。”
要的就是这个效果,进一步操作时作个判断就行了。

TA的精华主题

TA的得分主题

发表于 2013-4-8 07:39 | 显示全部楼层
小花鹿 发表于 2013-4-7 23:30
我运行了一下,效果很好,但我没有认认真真的测试,等我仔细测试后,有问题再向你请教。
希望通过我们的 ...

想要了解【递归】,看一下这个帖子吧,里面有较为基础的例子:

http://club.excelhome.net/thread-891872-2-1.html

简单说,递归就是既能遍历,又能深度搜索……进入到下一层后,按同样的规则处理。
因此效率很高,代码也会比单纯的循环遍历简单很多。

TA的精华主题

TA的得分主题

发表于 2013-4-8 08:30 | 显示全部楼层
小花鹿 发表于 2013-4-7 23:30
我运行了一下,效果很好,但我没有认认真真的测试,等我仔细测试后,有问题再向你请教。
希望通过我们的 ...

今天早上检查发现有2个bug,已在原帖纠正,请重新下载测试。

TA的精华主题

TA的得分主题

发表于 2013-4-8 08:48 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
另外,有空我来写个自动生成Dos 用的 Dir.bat 可执行文件,然后用Dos方法来返回所有文件名的方法……

呵呵。

TA的精华主题

TA的得分主题

发表于 2013-4-8 10:42 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Dos环境下获取所有文件夹(含子文件夹)内的Excel文件的方法也做好了。

速度是超快的……不过所得Dos格式的结果,未必满足你直接利用的要求。

仅作参考吧。

…………
做法:
1. 下载附件: DosDir.zip
2. 复制附件DosDir.zip到所需使用的文件夹内
3. 解压到当前文件夹得到3个文件,并按如下顺序打开文件:
  a. DosDir.xls  → 双击打开后宏自动运行,生成覆盖Dir.bat文件,然后自动关闭
   b. Dir.bat      → 双击打开后Dos自动运行Dir命令,然后自动关闭
   c. DosDirRslt.xls  → 双击打开,Dir结果已经列出在A列


以上

代码说明:
…………
DosDir.xls文件中ThisWorkbook代码页下有如下代开即自动执行命令
Private Sub Workbook_Open()
    Call DirBat
    ActiveWorkbook.Close False
End Sub
模块下宏命令
Sub DirBat()
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set f = FS.OpenTextFile(ThisWorkbook.Path & "\Dir.bat", 2, TristateFalse)
   
    f.Writeline "Dir """ & ThisWorkbook.Path & """\*.xl*/s>""DosDirRslt.xls"""
    f.Writeline "Exit"
    f.Close
End Sub

运行上述宏代码,自动生成Dir.bat 其中有如下命令:
Dir "[当前文件夹]\*.xl*/s>"DosDirRslt.xls"
Exit

例如:
Dir "D:"\*.xl*/s>"DosDirRslt.xls"
Exit

然后,运行Dir.bat中上述Dos命令,即可获取所有子文件夹内的全部Excel文件


呵呵。

DosDir.zip

5.74 KB, 下载次数: 35

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-4-10 16:31 | 显示全部楼层
无聊做了DosDir的第2版……直接Excel界面操作。

做法:
1. 下载附件: DosDir2.zip
2. 复制附件DosDir2.zip到所需使用的文件夹内
3. 解压到当前文件夹得到3个文件
  a. DosDir2.xls
   b. Dir.bat
    c. DosRslt.xls  → 双击打开,Dir结果已经列出在A列
4. 双击打开Excel文件DosDir2.xls后自动生成并覆盖Dir.bat,并自动运行DosDir命令
  过程中出现进度条……,Dos运行完成后自动关闭DosDir2.xls,并打开DosRslt.xls文件显示结果。


…………
呵呵。



DosDir2.zip

10.59 KB, 下载次数: 45

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-17 13:26 , Processed in 0.043689 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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