VBA获取指定文件夹下所有文件和子文件目录的文件

公司运营部门需要把影像资料梳理一遍，文件目录特别多，文件量也大，大概40多个G。自己写了一个读取目录下所有子文件的脚本
开始参考了 VBA获取某文件夹下所有文件和子文件目录的文件中的代码，按照此方式获取的结果有问题。
问题1 无法获取目录名中包含“.”的子目录

'-- 获得所有子目录
Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If InStr(f, ".") = 0 Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop

代码中使用InStr(f, “.”) = 0 判断，只要名字中包含"."就按照文件处理

问题2 无法获取扩展名为空的文件

'-- 获得所有子目录下的所有文件
For i = 1 To k
   f = Dir(file(i) & "*.*")    '通配符*.*表示所有文件，*.xlsx Excel文件
   Do Until f = ""
      'Range("a" & x) = f
      Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=file(i) & f, TextToDisplay:=f
       x = x + 1
       f = Dir
   Loop
Next

于是，自己实现了一个支持文件夹名称带“.”或文件名不带扩展名的。
实现过程
新建一个文件，在sheet1中增加两个按钮，一个用来选取文件夹，一个用来执行查询

1. 选择文件脚本

Option Explicit
Sub 打开文件夹()

   With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            Worksheets("Sheet1").Range("C5").Value = .SelectedItems(1)
        End If
    End With
 
End Sub

2. 执行脚本

Sub 按钮1_Click()

On Error Resume Next

Dim folderObj As Object
Dim currFolder
Dim fdCnt As Integer

Dim sDir As String

Dim dirExist, f As String
Dim file(), subFolder(), allfd() As String
Dim fileNum, k, x, idx, i, j, listNum
Dim threeDir As String

fileNum = 1
x = 1
k = 1
j = 0
i = 1

sDir = Worksheets("Sheet1").Range("C5").Value

'=== 0.清除数据=============================================
Sheet2.UsedRange.Clear

Worksheets("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 = xlContinuous
Worksheets("Sheet2").Range("A1").Borders.LineStyle = xlContinuous
Worksheets("Sheet2").Range("C1").Borders.LineStyle = xlContinuous
Worksheets("Sheet2").Range("D1").Borders.LineStyle = xlContinuous

'=== 1.判断选择的文件夹是否有效===============================

dirExist = dir(sDir, vbDirectory)
If dirExist = "" Then
    MsgBox ("选择的文件夹无效")
    Exit Sub
End If

'=== 2.获取所有子目录======================================

ReDim subFolder(1 To i)

subFolder(1) = sDir & "\"
f = dir(subFolder(1), vbDirectory)
Do Until f = ""
    If f <> "." And f <> ".." Then
        If (GetAttr(subFolder(1) & f) And vbDirectory) = 16 Then
            'Worksheets("Sheet3").Range("A" & k).Value = subFolder(1) & f & "\"
            k = k + 1
            ReDim Preserve subFolder(1 To k)
            subFolder(k) = subFolder(1) & f & "\"
        End If
    End If
    f = dir
Loop
i = i + 1

Dim tmp As Integer
tmp = 0

For Each fd In subFolder
    tmp = tmp + 1
    ReDim Preserve allfd(1 To tmp)
    i = 1
    k = 1
    Erase file
    ReDim file(1 To i)
    file(i) = fd
    allfd(tmp) = fd
    Worksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp)

    If subFolder(1) = file(i) Then
         f = dir
        i = i + 1
    Else

    Do Until i > k
        f = dir(file(i), vbDirectory)
        Do Until f = ""
            If f <> "." And f <> ".." Then
                If (GetAttr(file(i) & f) And vbDirectory) = 16 Then
                    k = k + 1
                    ReDim Preserve file(1 To k)
                    file(k) = file(i) & f & "\"
                    tmp = tmp + 1
                    ReDim Preserve allfd(1 To tmp)
                    allfd(tmp) = file(i) & f & "\"
                   ' Worksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp)
                End If
            End If
            f = dir
        Loop
        i = i + 1
    Loop
    End If
Next

'=== 3.获取所有子目录下的文件======================================
'
Dim threeStr As String

x = 2
idx = 1
For i = 1 To tmp
  
    f = dir(allfd(i) & "*.*")
    Do Until f = ""
        Worksheets("Sheet2").Range("A" & x).Value = idx
        Worksheets("Sheet2").Range("C" & x).Value = f
        Worksheets("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 = dir
        x = x + 1
        idx = idx + 1
    Loop
  
Next


End Sub

最终效果：

参考

1. W3CSchool VBA教程
2. VBA获取某文件夹下所有文件和子文件目录的文件
3. VBA 快速入门