小花鹿学习VBA记录

小花鹿

列出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

香川群子

递归调试好了：

今天早上再做测试时，发现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 08:26 上传

点击文件名下载附件

香川群子

小花鹿 发表于 2013-4-7 22:41
我上个附件吧：
结果放在：把此目录及子目录中的所有xls文件放在此中.xls
型如：C:\Documents and Se ...

附件测试通过……

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

小花鹿

香川群子 发表于 2013-4-7 23:03
递归调试好了：

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

小花鹿

香川群子 发表于 2013-4-7 23:10
附件测试通过……

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

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

香川群子

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

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

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

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

香川群子

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

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

香川群子

另外，有空我来写个自动生成Dos 用的 Dir.bat 可执行文件，然后用Dos方法来返回所有文件名的方法……

呵呵。

香川群子

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的第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文件显示结果。


…………
呵呵。