K
KeriM
I have a complicated problem. I'm trying to loop through severa
directories to find a particular file. Here is a sample of my folde
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 throug
those date folders. There are other folders in that MainDirectory, whic
is why I'm trying to limit the search to just those date folders. Her
is my code that lets me loop through the subfolders, but I can't dril
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
directories to find a particular file. Here is a sample of my folde
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 throug
those date folders. There are other folders in that MainDirectory, whic
is why I'm trying to limit the search to just those date folders. Her
is my code that lets me loop through the subfolders, but I can't dril
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