Excel VBA代码将父文件夹中的所有文件名捕获到excel表中

Question

我正在使用 VBA 代码将所有文件名从父文件夹捕获到 excel 中，下面的代码对我来说只能捕获一种文件格式，即.xlsm。 有没有办法捕获多种格式的文件，例如 PDF、JPEG、docx。

以下是 VBA 代码：-

Sub getallfiles()

    Dim fso As Object
    Dim parentfolder As Object
    Dim folder As Object
    Dim file As Object
    Dim filetype As String
    i = 1
    Filelocation = "C:\Users\USER\Desktop\VBA Practice"
    Range("A2").Select
    If ActiveCell.Value <> "" Then
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.ClearContents
    End If
    Set fso = CreateObject("scripting.filesystemobject")
    Set parentfolder = fso.Getfolder(Filelocation)
    filetype = "*.xlsm*"
    Listallfiles parentfolder,filetype
    For Each folder In parentfolder.Subfolders
        Listallfiles folder, filetype
        Next
End Sub

Answer 1

你没有向我们展示被调用的函数，我试着想象一个能够做你需要的事情。请用下一种方式测试你的代码：

Sub getallfiles()
 Dim fso As Object, parentfolder As Object, folder As Object, file As Object
 Dim fileType As Variant, Filelocation As String

 Filelocation = "C:\Users\USER\Desktop\VBA Practice" 'please use your real USER...
 Range("A2").Select
 If ActiveCell.Value <> "" Then
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
 End If
 Set fso = CreateObject("scripting.filesystemobject")
 Set parentfolder = fso.GetFolder(Filelocation)
 fileType = Array("xlsm", "pdf", "jpg", "docx") 'put here how many extensions you wang...
 ListAllFiles parentfolder, fileType, ActiveSheet
 For Each folder In parentfolder.SubFolders
     ListAllFiles folder, fileType, ActiveSheet
 Next
End Sub

Sub ListAllFiles(strFold As Object, fileType As Variant, sh As Worksheet)
 Dim fso As Object, objFile As Object, lastR As Long, mtch As Variant
 
    Set fso = CreateObject("scripting.filesystemobject")
    
    lastR = sh.Range("A" & sh.rows.count).End(xlUp).row + 1
        For Each objFile In strFold.files
           mtch = Application.match(fso.GetExtensionName(objFile.name), fileType, 0)
           If Not IsError(mtch) Then
                sh.Range("A" & lastR).Value = objFile: lastR = lastR + 1
           End If
        Next
End Sub

上面的代码可以使用一些优化，以便更快。最快的方法应该是使用一个数组，将它填充到被调用的 sub 中并在最后一次删除它的值......

已编辑：

1. 请在代码所在的模块顶部声明下一个变量（在声明区域中）：

Private arrFiles As Variant, iFile As Long

1. 在您声明上述变量的标准模块中复制下一个改编代码：

Sub getallfilesArrray() 
 Dim fso As Object, parentfolder As Object, folder As Object, file As Object
 Dim fileType As Variant, Filelocation As String

 Filelocation = "C:\Users\USER\Desktop\VBA Practice"
 Range("A2").CurrentRegion.ClearContents

 Set fso = CreateObject("scripting.filesystemobject")
 iFile = 1
 ReDim arrFiles(1 To 2, 1 To 1000) 'if the estimation for existing files is bigger, use a bigger number
 Set parentfolder = fso.GetFolder(Filelocation)
 fileType = Array("xlsm", "pdf", "jpg", "docx")
 ListAllFilesA parentfolder, fileType
 For Each folder In parentfolder.SubFolders
     ListAllFilesA folder, fileType
 Next
 ReDim Preserve arrFiles(1 To 2, 1 To iFile - 1)
 With Range("A2").Resize(iFile - 1, 2)
    .Value = Application.Transpose(arrFiles)
    .EntireColumn.AutoFit
 End With
 MsgBox "Ready..."
End Sub

Sub ListAllFilesA(strFold As Object, fileType As Variant)
 Dim fso As Object, objFile As Object, mtch As Variant
 
    Set fso = CreateObject("scripting.filesystemobject")
    
        For Each objFile In strFold.files
           mtch = Application.match(fso.GetExtensionName(objFile.name), fileType, 0)
           If Not IsError(mtch) Then
                arrFiles(1, iFile) = objFile
                arrFiles(2, iFile) = objFile.name
                iFile = iFile + 1
           End If
        Next
End Sub