修改列出 Folders/Sub-Folders 以包含文件名的现有代码

Question

我有一个代码可以完整列出给定路径中的所有文件夹和子文件夹。我愚蠢地运行一个包含数万个子文件夹的文件夹中的代码，所以在等待它完成的同时我想开始考虑下一步。

我还需要代码来深入兔子洞并获取文件名。这是代码：

Option Explicit 

    Dim i As Long, j As Long 
    Dim searchfolders As Variant 
    Dim FileSystemObject 

    Sub ListOfFolders() 
        Dim LookInTheFolder As String 

        i = 1 
        LookInTheFolder = "C:\" ' As you know; you should modificate this row.
        Set FileSystemObject = CreateObject("Scripting.FileSystemObject") 
        For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders 
            Cells(i, 1) = searchfolders 
            i = i + 1 
            SearchWithin searchfolders 
        Next searchfolders 

    End Sub 

Sub SearchWithin(searchfolders) 
        On Error GoTo exits 
    For Each searchfolders In FileSystemObject.GetFolder(searchfolders).SubFolders 
        j = UBound(Split(searchfolders, "\")) 
        Cells(i, j) = searchfolders 
        i = i + 1 
        SearchWithin searchfolders 
        Next searchfolders 
        exits: 
End Sub

代码输出到树状图表中，我想扩展到最后一个 b运行ch，包括文件名。

请帮忙！谢谢。

Answer 1

我不得不这样做很多次，并且多次使用相同的功能。

Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'

    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

只需将文件的整个路径传递给函数即可。它将 return 文件名。

另一个选项是这个函数。

Public Function RecursiveDir(colFiles As Collection, _
                          ByVal strFolder As String, _
                          strFileSpec As String, _
                          bIncludeSubfolders As Boolean)

 Dim strTemp As String
 Dim colFolders As New Collection
 Dim vFolderName As Variant

'Add files in strFolder matching strFileSpec to colFiles
 strFolder = TrailingSlash(strFolder)
 strTemp = Dir(strFolder & strFileSpec)
 Do While strTemp <> vbNullString
     colFiles.Add strFolder & strTemp
     strTemp = Dir
 Loop

'Fill colFolders with list of subdirectories of strFolder
 If bIncludeSubfolders Then
     strTemp = Dir(strFolder, vbDirectory)
     Do While strTemp <> vbNullString
         If (strTemp <> ".") And (strTemp <> "..") Then
             If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                 colFolders.Add strTemp
             End If
         End If
         strTemp = Dir
     Loop

'Call RecursiveDir for each subfolder in colFolders
     For Each vFolderName In colFolders
         Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
     Next vFolderName
 End If

'Garbage collection
 Set colFolders = Nothing

End Function

此函数将填充给定目录中每个文件名的集合。如果您愿意，可以将 bIncludeSubfolders 设置为 true，它将递归搜索该目录中的所有子文件夹。要使用此功能，您需要具备以下条件：

Dim colFiles As New Collection ' The collection of files
Dim Path As String ' The parent Directory you want to search
Dim subFold As Boolean ' Search sub folders, yes or no?
Dim FileExt As String ' File extension type to search for

然后只需设置 FileExt = "*.*" 即可找到具有每个文件扩展名的每个文件。希望这对您有所帮助。

修改列出 Folders/Sub-Folders 以包含文件名的现有代码

Modify Existing Code that Lists Folders/Sub-Folders to Include File Names

directory

excel

vba