从网上找了一些信息,自己修改了一下
方式很直白,先把所有的目录找了出来,然后一个个目录来处理。
虽然与我习惯使用迭代的的方式有所差别,但也很好。
后面的函数是原始的,没有改动,主函数自己重新写过了。
'主函数
Sub ListFilesInCurFolder() '//函数实例
Cells(1, 1) = "序号"
Cells(1, 2) = "文件名称"
Cells(1, 3) = "文件类型"
Cells(1, 4) = "路径"
Dim strCurfileName
Dim CurRow
CurRow = 2
arr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name)
For I = 0 To UBound(arr)
' MsgBox arr(I)
'Set WB = Workbooks.Open(arr(I))
'你的代码
'WB.Close False
'lj = "E:\ToolDev\ExcelTools\ListFileInFolder\test"
Dim wj As String
'wj = Dir(lj & "\*.*")
Dim idx As Integer
idx = InStrRev(arr(I), "\")
If idx >= 0 Then
strCurfileName = Mid(arr(I), idx + 1, Len(arr(I)))
Else
strCurfileName = arr(I)
End If
'Cells(([A65536].End(xlUp).Row + 1), 1) = [A65536].End(xlUp).Row
' Cells(([C65536].End(xlUp).Row + 1), 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
' Cells(([B65536].End(xlUp).Row + 1), 2).Select
Cells(CurRow, 1) = CurRow - 1
Cells(CurRow, 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
Cells(CurRow, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=arr(I), TextToDisplay:=strCurfileName
'相对路径,但证明无用,绝对路径,在excel中,会被自动转为相对路径
'Cells(CurRow, 4).Select
'Dim RefPath
'RefPath = Mid(arr(I), Len(ThisWorkbook.Path) + 2, Len(arr(I)))
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=RefPath, TextToDisplay:=strCurfileName
'''''''''''''
Cells(CurRow, 4).Select
Dim CurFolder
CurFolder = Left(arr(I), idx)
CurFolder = Mid(CurFolder, Len(ThisWorkbook.Path) + 2, Len(CurFolder))
Cells(CurRow, 4) = CurFolder
CurRow = CurRow + 1
Next
Columns("A:C").Select
Columns("A:C").EntireColumn.AutoFit
End Sub
'****************************************************************
'功能: 查找指定文件夹含子文件夹内所有文件名(含路径)
'函数名: FileAllArr
'参数1: Filename 需查找的文件夹名 不含最后的"\"
'参数2: FileFilter 需要过滤的文件名,可省略,默认为:[*.*]
'参数3: Liwai 剔除例外的文件名,可省略,默认为:空,一般为:ThisWorkbook.Name
'返回值: 一个字符型的数组
'使用方法:arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()
Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象
Set Did = CreateObject("Scripting.Dictionary")
Dic.Add (Filename & "\"), ""
I = 0
Do While I < Dic.Count
Ke = Dic.keys '开始遍历字典
MyName = Dir(Ke(I), vbDirectory) '查找目录
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
Dic.Add (Ke(I) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
I = I + 1
Loop
I = 0
Dim arrx() As String
For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
MyFileName = Dir(Ke & FileFilter) '过滤器:EXCEL2003为:*.xls,excel2007为:*.xlsx
Do While MyFileName <> ""
If MyFileName <> Liwai Then '排除例外文件
ReDim Preserve arrx(I)
arrx(I) = Ke & MyFileName
I = I + 1
End If
MyFileName = Dir
Loop
Next
FileAllArr = arrx
End Function
'****************************************************************
'Sub g1()
' Dim fso, fl, m&
' Set fso = CreateObject("Scripting.FileSystemObject")
' For Each fl In fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & "\").Files
' m = m + 1
' Cells(m, 2) = fl.Name
' Next
' End Sub