公司运营部门需要把影像资料梳理一遍，文件目录特别多，文件量也大，大概40多个G。自己写了一个读取目录下所有子文件的脚本
开始参考了 VBA获取某文件夹下所有文件和子文件目录的文件中的代码，按照此方式获取的结果有问题。
问题1无法获取目录名中包含“.”的子目录
'-- 获得所有子目录Do Until i > kf = Dir(file(i), vbDirectory)Do Until f = ""If InStr(f, ".") = 0 Thenk = k + 1ReDim Preserve file(1 To k)file(k) = file(i) & f & "\"End Iff = DirLoopi = i + 1Loop
代码中使用InStr(f, “.”) = 0 判断，只要名字中包含"."就按照文件处理
问题2无法获取扩展名为空的文件
'-- 获得所有子目录下的所有文件For i = 1 To kf = Dir(file(i) & "*.*") '通配符*.*表示所有文件，*.xlsx Excel文件Do Until f = ""'Range("a" & x) = fRange("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=file(i) & f, TextToDisplay:=fx = x + 1f = DirLoopNext
于是，自己实现了一个支持文件夹名称带“.”或文件名不带扩展名的。
实现过程
新建一个文件，在sheet1中增加两个按钮，一个用来选取文件夹，一个用来执行查询
选择文件脚本
Option ExplicitSub 打开文件夹()With Application.FileDialog(msoFileDialogFolderPicker)If .Show = -1 ThenWorksheets("Sheet1").Range("C5").Value = .SelectedItems(1)End IfEnd WithEnd Sub
执行脚本
Sub 按钮1_Click()On Error Resume NextDim folderObj As ObjectDim currFolderDim fdCnt As IntegerDim sDir As StringDim dirExist, f As StringDim file(), subFolder(), allfd() As StringDim fileNum, k, x, idx, i, j, listNumDim threeDir As StringfileNum = 1x = 1k = 1j = 0i = 1sDir = Worksheets("Sheet1").Range("C5").Value'=== 0.清除数据=============================================Sheet2.UsedRange.ClearWorksheets("Sheet2").Range("A1").Value = "序号"Worksheets("Sheet2").Range("C1").Value = "文件名"Worksheets("Sheet2").Range("D1").Value = "文件路径"Worksheets("Sheet2").Range("E1").Value = "文件格式"Worksheets("Sheet2").Range("E1").Interior.Color = RGB(255, 255, 0)Worksheets("Sheet2").Range("A1").Interior.Color = RGB(255, 255, 0)Worksheets("Sheet2").Range("C1").Interior.Color = RGB(255, 255, 0)Worksheets("Sheet2").Range("D1").Interior.Color = RGB(255, 255, 0)Worksheets("Sheet2").Range("E1").Borders.LineStyle = xlContinuousWorksheets("Sheet2").Range("A1").Borders.LineStyle = xlContinuousWorksheets("Sheet2").Range("C1").Borders.LineStyle = xlContinuousWorksheets("Sheet2").Range("D1").Borders.LineStyle = xlContinuous'=== 1.判断选择的文件夹是否有效===============================dirExist = dir(sDir, vbDirectory)If dirExist = "" ThenMsgBox ("选择的文件夹无效")Exit SubEnd If'=== 2.获取所有子目录======================================ReDim subFolder(1 To i)subFolder(1) = sDir & "\"f = dir(subFolder(1), vbDirectory)Do Until f = ""If f <> "." And f <> ".." ThenIf (GetAttr(subFolder(1) & f) And vbDirectory) = 16 Then'Worksheets("Sheet3").Range("A" & k).Value = subFolder(1) & f & "\"k = k + 1ReDim Preserve subFolder(1 To k)subFolder(k) = subFolder(1) & f & "\"End IfEnd Iff = dirLoopi = i + 1Dim tmp As Integertmp = 0For Each fd In subFoldertmp = tmp + 1ReDim Preserve allfd(1 To tmp)i = 1k = 1Erase fileReDim file(1 To i)file(i) = fdallfd(tmp) = fdWorksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp)If subFolder(1) = file(i) Thenf = diri = i + 1ElseDo Until i > kf = dir(file(i), vbDirectory)Do Until f = ""If f <> "." And f <> ".." ThenIf (GetAttr(file(i) & f) And vbDirectory) = 16 Thenk = k + 1ReDim Preserve file(1 To k)file(k) = file(i) & f & "\"tmp = tmp + 1ReDim Preserve allfd(1 To tmp)allfd(tmp) = file(i) & f & "\"' Worksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp)End IfEnd Iff = dirLoopi = i + 1LoopEnd IfNext'=== 3.获取所有子目录下的文件======================================'Dim threeStr As Stringx = 2idx = 1For i = 1 To tmpf = dir(allfd(i) & "*.*")Do Until f = ""Worksheets("Sheet2").Range("A" & x).Value = idxWorksheets("Sheet2").Range("C" & x).Value = fWorksheets("Sheet2").Range("D" & x).Value = Replace(allfd(i), sDir, "") & f'Worksheets("Sheet2").Range("E" & x).Value = getFileType(f)'Worksheets("Sheet2").Range("B" & x).NumberFormatLocal = "@"'Worksheets("Sheet2").Range("B" & x).Value = getToubaodanHao(sDir, allfd(i))f = dirx = x + 1idx = idx + 1LoopNextEnd Sub
最终效果：
