In the folder Data I have three other folders that each contain .xlsm files. To try and go through all these folders I'm trying a recursive formula like this or in a collection to find all the files. I need to store the full path of these files to use in the main macro at the bottom and do various things. Currently this stores the last file in the iteration but I need a full list, I've tried using an array but i'm struggling to either store it or send it out of the function. Any help would be appreciated
Function LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
Dim variable As String
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders 1
Else
variable = folderPath & fileName
'Debug.Print variable
'Debug.Print folderPath & fileName
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
LoopAllSubFolders folders(i)
Next i
LoopAllSubFolders = variable
End Function
Sub loopAllSubFolderSelectStartDirectory()
Output = LoopAllSubFolders("Data\")
Debug.Print Output
End Sub
CodePudding user response：
use a collection for example to add the results, eg.:
Option Explicit
Dim output
Dim col As Collection
Function LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
Dim variable As String
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders 1
Else
variable = folderPath & fileName
Call col.Add(variable, variable)
' Debug.Print variable
'Debug.Print folderPath & fileName
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
LoopAllSubFolders folders(i)
Next i
LoopAllSubFolders = variable
End Function
Sub loopAllSubFolderSelectStartDirectory()
Dim i As Long
Set col = New Collection
output = LoopAllSubFolders("Data\")
For i = 1 To col.Count
Debug.Print col(i)
Next i
End Sub
CodePudding user response：
Return File Paths in Collection Using FileSystemObject Object
Utilization (Example)
Sub CollSubfolderFilePathsTEST()
' Define constants.
Const FolderPath As String = "C:\Test"
Const FilePattern As String = "*.xlsm"
Const IncludeFolderPath As Boolean = False
' Return the file paths in a collection ('collFilePaths')
Dim collFilePaths As Collection: Set collFilePaths _
= CollSubfolderFilePaths(FolderPath, FilePattern, IncludeFolderPath)
' Validate the collection.
If collFilePaths Is Nothing Then Exit Sub
Dim Item As Variant
' Loop through the collection to print each item.
For Each Item In collFilePaths
Debug.Print Item
Next Item
End Sub
The Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the paths of all files of a folder ('FolderPath')
' and all of its subfolders in a collection.
' Remarks: It uses the FileSystemObject object.
' If an error occurs, if the initial folder doesn't exist, or
' if no file is found, the function will return 'Nothing'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollSubfolderFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*.*", _
Optional ByVal IncludeFolderPath As Boolean = True) _
As Collection
Const ProcName As String = "CollSubfolderFilePaths"
On Error GoTo ClearError
' Create and reference a FileSystemObject object ('fso').
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the initial folder path ('FolderPath').
If Not fso.FolderExists(FolderPath) Then Exit Function
' Define the Paths collection ('collPaths') to hold the paths of all files
' in the initial folder path and in each of its subfolders.
Dim collPaths As Collection: Set collPaths = New Collection
' Define the Queue collection ('collQueue') to hold
' the initial folder (object) and all of its subfolders (objects)
' before the paths of their files are stored in the Paths collection
' and they are removed (from the Queue collection).
Dim collQueue As Collection: Set collQueue = New Collection
' Add the initial folder (object) to the Queue collection.
collQueue.Add fso.GetFolder(FolderPath)
Dim fsoFolder As Object ' Current Folder
Dim fsoSubfolder As Object ' Current Subfolder
Dim fsoFile As Object ' Current File in the Current Folder
Do Until collQueue.Count = 0
' Reference the current folder ('fsoFolder'),
' the first folder in the Queue collection.
Set fsoFolder = collQueue(1)
' Remove the current (first) folder from the Queue collection.
collQueue.Remove 1 ' dequeue!
' Loop through the subfolders ('fsoSubfolder') of the current folder.
For Each fsoSubfolder In fsoFolder.Subfolders
' Add the current subfolder to the Queue collection.
collQueue.Add fsoSubfolder ' enqueue!
Next fsoSubfolder
If IncludeFolderPath Then ' do not skip the intial folder path
' Loop through the files ('fsoFile') in the folder.
For Each fsoFile In fsoFolder.Files
' Using the Like operator, check the current file's name
' against the file pattern ensuring case-insensitivity
' by using the LCase function.
If LCase(fsoFile.Name) Like LCase(FilePattern) Then
' Add the current file's path to the collection.
collPaths.Add fsoFile.Path
End If
Next fsoFile
Else ' skip the initial folder path
IncludeFolderPath = True
End If
Loop
' When no file was found, avoid passing a collection with 0 items
' to be able to always validate it by checking it just against 'Nothing'
' in the calling procedure.
If collPaths.Count = 0 Then Exit Function
' Pass the Paths collection to the result of the function.
Set CollSubfolderFilePaths = collPaths
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
Return Folder Paths in Collection Using FileSystemObject Object
Utilization (Example)
Sub CollSubfolderPathsTEST()
' Define constants.
Const FolderPath As String = "C:\Test"
Const IncludeFolderPath As Boolean = True
' Return the folder paths in a collection ('collFolderPaths')
Dim collFolderPaths As Collection: Set collFolderPaths _
= CollSubfolderPaths(FolderPath, IncludeFolderPath)
' Validate the collection.
If collFolderPaths Is Nothing Then Exit Sub
Dim Item As Variant
' Loop through the collection to print each item.
For Each Item In collFolderPaths
Debug.Print Item
Next Item
End Sub
The Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the paths of a folder ('FolderPath')
' and all of its subfolders in a collection.
' Remarks: It uses the FileSystemObject object.
' If an error occurs, if the initial folder doesn't exist, or
' if no folder is found (only when 'IncludFolderPath = False'),
' the function will return 'Nothing'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollSubfolderPaths( _
ByVal FolderPath As String, _
Optional ByVal IncludeFolderPath As Boolean = True) _
As Collection
Const ProcName As String = "CollSubFolderPaths"
On Error GoTo ClearError
' Create and reference a FileSystemObject object ('fso').
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the initial folder path ('FolderPath').
If Not fso.FolderExists(FolderPath) Then Exit Function
' Define the Paths collection ('collPaths') to hold
' the initial folder path and the paths of each subfolder.
Dim collPaths As Collection: Set collPaths = New Collection
' Define the Queue collection ('collQueue') to hold
' the initial folder (object) and all of its subfolders (objects)
' before their path is stored in the Paths collection
' and they are removed (from the Queue collection).
Dim collQueue As Collection: Set collQueue = New Collection
' Add the initial folder (object) to the Queue collection.
collQueue.Add fso.GetFolder(FolderPath)
Dim fsoFolder As Object ' Current Folder
Dim fsoSubfolder As Object ' Current Subfolder
Do Until collQueue.Count = 0
' Reference the current folder ('fsoFolder'),
' the first folder in the Queue collection.
Set fsoFolder = collQueue(1)
' Remove the current (first) folder from the Queue collection.
collQueue.Remove 1 ' dequeue!
' Add the path of the current folder to the Paths collection.
collPaths.Add fsoFolder.Path
' Loop through the subfolders of the current folder (referencing each).
For Each fsoSubfolder In fsoFolder.Subfolders
' Add the current subfolder to the Queue collection.
collQueue.Add fsoSubfolder ' enqueue!
Next fsoSubfolder
Loop
' The following illustration helped me to understand the code
' in the Do...Until loop whose part related to the Queue collection
' is emulating the functionality of a FIFO type (first in, first out)
' data structure called a queue.
' Level Folder Structure
' 1 A
' 2 B C D
' 3 E F G H I
' 4 J
' Iteration Removed Path Added Added Description Count Status
' 1 A A B,C,D Subfolders of A 3 B,C,D
' 2 B A\B E,F Subfolders of B 4 C,D,E,F
' 3 C A\C 3 D,E,F
' 4 D A\D G,H,I Subfolders of D 5 E,F,G,H,I
' 5 E A\B\E 4 F,G,H,I
' 6 F A\B\F 3 G,H,I
' 7 G A\D\G J Subfolders of G 3 H,I,J
' 8 H A\D\H 2 I,J
' 9 I A\D\I 1 J
' 10 J A\D\G\J 0
If Not IncludeFolderPath Then
' When the path of the initial folder was the only path
' in the Paths collection, avoid passing a collection with 0 items
' to be able to always validate it by checking it just against 'Nothing'
' in the calling procedure.
If collPaths.Count = 1 Then Exit Function
' Remove the path of the initial folder from the Paths collection.
collPaths.Remove 1
End If
' Pass the Paths collection to the result of the function.
Set CollSubfolderPaths = collPaths
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function