i have this code below to get files names from a specific folder and it works great. i like how is transposes the file names it works really well with how i do my work.

what i want to change is to have it also return the file names with in the subfolders to. but carry on transposing it accrss my work sheet.

Thank you.

Function GetFileNames6(ByVal FolderPath As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim myFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set myFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = myFolder.Files
ReDim Result(1 To MyFiles.Count)
i = 1
o = 1
For Each MyFile In MyFiles
Result(i) = MyFile.name & " " & MyFile.DateCreated
i = i   1

Next MyFile
GetFileNames6 = Result

End Function

CodePudding user response：

Return File Names From All Folders and Subfolders

Issues

• Files containing 'non-standard' characters like e.g. žćčšđ will be returned by the ArrFilePaths function using the WScript Host but will not be found by the FileSystemObject object (nor the Dir function) hence the complications in the GetFileNames6function. If you have such characters in your file- or folder names, you can ask another question.
• I've used something like Dim Arr() As String: Arr = Split("") to get an 'empty' string array in both functions. Not sure if that's the ideal way since I've never seen it done before.

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Tests the 'GetFileNames6' function.
' Calls:        GetFileNames6
'                   ArrFilePaths
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetFileNames6TEST()
    
    Const FolderPath As String = "C:\Test\"
     
    Dim NamesDates() As String: NamesDates = GetFileNames6(FolderPath)
    
    If UBound(NamesDates) = -1 Then
        Debug.Print "No files found."
        Exit Sub
    End If
    
    Debug.Print Join(NamesDates, vbLf)
   
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a zero-based string array containing the concatenated
'               names and dates ('DateCreated') from a given zero-based string
'               array containing file paths.
' Calls:        ArrFilePaths.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFileNames6( _
    ByVal FolderPath As String, _
    Optional ByVal Delimiter As String = " ") _
As String()
    Const ProcName As String = "GetFileNames6"
    On Error GoTo ClearError
    
    ' Ensuring that a string array is passed if an error occurs.
    GetFileNames6 = Split("") ' LB = 0 , UB = -1
    
    Dim FilePaths() As String: FilePaths = ArrFilePaths(FolderPath)
    'Debug.Print Join(FilePaths, vbLf)
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim fsoFile As Object
    Dim n As Long ' Files Count
    Dim fCount As Long ' Found Files Count
    
    For n = 0 To UBound(FilePaths)
        If fso.FileExists(FilePaths(n)) Then
            Set fsoFile = fso.GetFile(FilePaths(n))
            FilePaths(fCount) = fsoFile.Name & Delimiter & fsoFile.DateCreated
            fCount = fCount   1
        Else ' happens if not 'standard characters' (character map?)
            Debug.Print "Not found:             " & FilePaths(n)
        End If
    Next n
        
    If fCount < n Then
        ReDim Preserve FilePaths(0 To fCount - 1)
        'Debug.Print Join(FilePaths, vbLf)
        Debug.Print "Initially found files: " & n
        Debug.Print "Finally found files:   " & fCount
    End If
        
    GetFileNames6 = FilePaths

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files in a folder in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As String()
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    ' Ensuring that a string array is passed if an error occurs.
    ArrFilePaths = Split("") ' LB = 0 , UB = -1
   
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)
    If UBound(Arr) > 0 Then
        ReDim Preserve Arr(0 To UBound(Arr) - 1)
    End If
    ArrFilePaths = Arr

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function