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

【引用位置】 https://blog.csdn.net/pashine/article/details/42100237

'-------------------------------------------

'获取某文件夹下的所有Excel文件

'-------------------------------------------

Sub getExcelFile(sFolderPath As String)

On Error Resume Next

Dim f As String

Dim file() As String

Dim x

k = 1

ReDim file(1)

file(1) = sFolderPath &""

End Sub

'-------------------------------------------

'获取某文件夹下的所有文件和子目录下的文件

'-------------------------------------------

Sub getAllFile(sFolderPath As String)

'Columns(1).Delete

On Error Resume Next

Dim f As String

Dim file() As String

Dim i, k, x

x = 1

i = 1

k = 1

ReDim file(1 To i)

file(1) = sFolderPath &""

'-- 获得所有子目录

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

'-- 获得所有子目录下的所有文件

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

End Sub

答：执行"获取所有文件夹"，按提示 *** 作。文件夹清单会显示在工作表的AB列中。

Sub 获取所有文件夹()

    Dim Directory As String

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = Application.DefaultFilePath & "\"

        .Title = "请选择一个文件夹"

        .Show

        If .SelectedItems.Count = 0 Then

            Exit Sub

        Else

            Directory = .SelectedItems(1)

        End If

    End With

    Cells.ClearContents

    Call RecursiveDir(Directory)

End Sub

Public Sub RecursiveDir(ByVal CurrDir As String)

    Dim Dirs() As String

    Dim NumDirs As Long

    Dim Filesize As Double

    Dim TotalFolders, SingleFolder

    Cells(1, 1) = "目录名"

    Cells(1, 2) = "日期/时间"

    Range("A1:B1").Font.Bold = True

    

    Set TotalFolders = CreateObject("Scripting.FileSystemObject").GetFolder(CurrDir).SubFolders

    Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir

    Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileDateTime(CurrDir)

    If TotalFolders.Count <> 0 Then

        For Each SingleFolder In TotalFolders

            ReDim Preserve Dirs(0 To NumDirs) As String

            Dirs(NumDirs) = SingleFolder

            NumDirs = NumDirs + 1

        Next

    End If

    For i = 0 To NumDirs - 1

        RecursiveDir Dirs(i)

    Next i

End Sub

Sub copyFiles(Path As String, afterPath)

'Path：原文件夹路径；afterPath：目标文件夹路径

Dim Spath As String

Set fs = CreateObject("Scripting.FileSystemObject")

Spath = Dir(Path, vbDirectory)

Do While Len(Spath)

If Spath <>"." And Spath <>".." Then

fs.CopyFolder Path, afterPath

Spath = Dir()

End If

Loop

End Sub

————————————————

版权声明：本文为CSDN博主「前端小菜鸟007」的原创文章，遵循CC 4.0 BY-SA版权协议，转载请附上原文出处链接及本声明。

原文链接：https://blog.csdn.net/weixin_41844140/article/details/103188537

---