|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
请兄弟姐妹帮忙看看能否不使用全局变量(dirarr)实现
或者能更好的优化,dir 和search 的方法不在讨论范围
递归.zip
(32.55 KB, 下载次数: 16)
Option Explicit
Dim dirArr()
'调用函数过程
Sub test()
Dim a
a = MainDira_dbs(文件夹地址)
[a1].Resize(UBound(a, 1), UBound(a, 2)).Value = a
Erase a
End Sub
'以下是实现函数
Function MainDira_dbs(ByRef FolderAddress As String)
ReDim dirArr(1 To 3, 1 To 65536) '为了写工作表,文件总数不超过65535个,不使用dirArr(1 To 65536, 1 To 3)是因为Preserve只能改变末维,参见ReDim Preserve dirArr行。
dirArr(1, 1) = 1 '开始计数,不从0开始是因为需要留出第1行写计数项( count=dirArr(1, 1) ),以便实现递归。
Dira_dbs CreateObject("scripting.filesystemobject").GetFolder(FolderAddress) '调用Dira_dbs子函数
ReDim Preserve dirArr(1 To 3, 1 To dirArr(1, 1)) '以下几行处理dirarr,以便写入工作表。
dirArr(2, 1) = "FilesCount:" & dirArr(1, 1) - 1
dirArr(1, 1) = "FolderAddress:" & FolderAddress
dirArr = Application.WorksheetFunction.Transpose(dirArr)
MainDira_dbs = dirArr: Erase dirArr '这里的erase是不是有点多余?
End Function
Private Sub Dira_dbs(ByVal FatherFolder)
Dim dirFile '后绑定,所以没有详细定义
Dim dirFolder
With CreateObject("scripting.filesystemobject")
If FatherFolder.Files.Count <> 0 Then
For Each dirFile In FatherFolder.Files
dirArr(1, 1) = dirArr(1, 1) + 1
dirArr(1, dirArr(1, 1)) = dirFile.Path '路径
dirArr(2, dirArr(1, 1)) = .GetBaseName(dirFile.Path) '文件名
dirArr(3, dirArr(1, 1)) = .GetExtensionName(dirFile.Path) '后缀名
Next dirFile
End If
If FatherFolder.SubFolders.Count <> 0 Then '这里是递归的出口
For Each dirFolder In FatherFolder.SubFolders
Dira_dbs dirFolder
Next
End If
End With
End Sub |
|