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

[KeriM]

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!




--
KeriM

[GS]

Have a look here to see if this might be worth modifying for your
purposes...

http://vb.mvpb.org/samples/DirDrill/

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

[pb]

Garry,
I don't know about any other "lurkers" on here, but the link did not work for me.
-pb

[GS]

> Garry,
> I don't know about any other "lurkers" on here, but the link did not
> work for me. -pb

Geez.., thanks for the feedback! Big typo on my part...

http://vb.mvps.org/samples/DirDrill/