ExcelBanter - VBA Loop through Specific Subfolders to find files (drill down 4 levels)

I have a complicated problem. I'm trying to loop through several directories to find a particular file. Here is a sample of my folder structure "MainDirectory/YYYYMMDD/DETAILS/FOLDER/File.xlsx".

My goal is to find that particular file, but I need to drill down to it. I have to start at that MainDirectory, because I need to loop through those date folders. There are other folders in that MainDirectory, which is why I'm trying to limit the search to just those date folders. Here is my code that lets me loop through the subfolders, but I can't drill down far enough to find my file.

Code:

  Public Folder_Name2 As String



  Private Declare Function SetCurrentDirectoryA Lib _

    "kernel32" (ByVal lpPathName As String) As Long

   

  Public Function Path_Name2()

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = "C:\MyDocuments\"

        .Show

    End With

    On Error Resume Next

    Path_Name2 = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

    Err.Clear

    On Error GoTo 0

  On Error GoTo 0

  End Function

    

Sub ChDirNet(szPath As String)

    Dim lReturn As Long

        lReturn = SetCurrentDirectoryA(szPath)

    If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."

End Sub



Sub ListFiles()

   Call ListFilesInFolder_2014(Path_Name2, True, False)

End Sub



'BUILD LIST OF FILES TO IMPORT

Function ListFilesInFolder_2014(SourceFolderName As String, IncludeSubfolders As Boolean, IncludeEmptyFolders As Boolean)

' lists information about the files in SourceFolder

' example: ListFilesInFolder "C:\FolderName\", True

Dim FSO As Scripting.FileSystemObject

Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder

Dim FileItem As Scripting.File

'Dim r As Long

Dim strChar As String

Dim strChildFolder As String

Dim strFullPath As String

Dim intFCount As Integer

Dim strSourceFolderName As String

On Error GoTo Errhandler



    Set FSO = New Scripting.FileSystemObject

    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    'r = Range("A65536").End(xlUp).Row + 1

    intFCount = SourceFolder.Files.Count

    strSourceFolderName = SourceFolder.Path

    Debug.Print (strSourceFolderName)

    If intFCount = 0 Then

    End If

    

    For Each FileItem In SourceFolder.Files

        ' display file properties

                    intCheck = 1

                    strChar = ""

                    Do Until Left(strChar, 1) = "\"

                        strChar = Right(FileItem.ParentFolder, intCheck)

                        strChildFolder = strChar & strChildFolder

                        intCheck = 1 + intCheck

                    Loop

            strChildFolder = Trim(Mid(strChar, 2, 20))

            'Debug.Print FileItem.Name & "[]" & strChildFolder

        'With FileItem

          If FileItem.Name = "FileName.xlsx" Then

                Workbooks.Open (FileItem.Path)

                'Do whatever

                Workbooks(FileItem.Name).Close SaveChanges:=False

            End If

    

    Next FileItem

    If IncludeSubfolders Then

        For Each SubFolder In SourceFolder.SubFolders

            ListFilesInFolder SubFolder.Path, True, IncludeEmptyFolders

        Next SubFolder

    End If

    Set FileItem = Nothing

    Set SourceFolder = Nothing

    Set FSO = Nothing

Exit Function



Errhandler:

MsgBox Err.Number & " - " & Err.Description

End Function

Any help is appreciated!