Trex_tony
05-26-2022, 12:51 PM
Hi folks,
I am trying to firstly get a list of subfolders within a given folder, then get a specific filename from within each subfolder (they have different names but all end with "*Mosaix.zvi)
I am having considerable trouble with this, as the first part is trivial but the second part is proving quite difficult for a VBA novice like myself!
I have approached it in 2 ways, using Dir (which crashes instantly when running) and FSO (which doesn't return the filenames at all), as follows:
Sub loopThroughAllFolders()
Dim basePath, fileSearch, fileName, folderPathString, filePathString, filePath, subFolders As String
Dim idx As Integer
basePath = "F:\Petrography Images\"
fileSearch = "*Mosaix.zvi"
idx = 0
subFolders = Dir(basePath, vbDirectory)
Do While subFolders <> ""
If subFolders <> "." And subFolders <> ".." Then
idx = idx + 1
folderPathString = basePath & subFolders & "\"
If GetAttr(folderPathString) = vbDirectory Then
filePathString = folderPathString & fileSearch
fileName = Dir(filePathString, vbDirectory)
filePath = folderPathString & fileName
End If
Cells(idx, 1).Value = subFolders
Cells(idx, 2).Value = fileName
subFolders = Dir()
End If
Loop
End Sub
and FSO:
Sub LoopSubfoldersAndFiles()
Dim fso As Object, folder As Object, subfolders As Object, allFiles As Variant
Dim MyFile As String, fileStr As String
Dim idxFolders , idxFiles As Integer
Dim folderCount As Integer
Dim arrFolders(), arrFiles() As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("F:\Petrography Images\")
Set subfolders = folder.subfolders
fileStr = "*Mosaix.zvi"
idxFolders = 0
idxFiles = 0
folderCount = subfolders.Count
If folderCount > 0 Then
ReDim arrFolders(1 To folderCount)
ReDim arrFiles(1 To folderCount)
End If
For Each subfolders In subfolders
idxFolders = idxFolders + 1
arrFolders(idxFolders) = subfolders.Name
For Each allFiles In subfolders.Files
If InStr(allFiles.Name, "*Mosaix.zvi") > 0 Then
idxFiles = idxFiles + 1
fileNames(idxFiles) = allFiles.Name
End If
Next
Next
Range("A1").Resize(folderCount).Value = Application.Transpose(arrFolders)
Range("B1").Resize(idxFiles).Value = Application.Transpose(fileNames)
Set fso = Nothing
Set folder = Nothing
Set subfolders = Nothing
End Sub
Any help in solving this would be greatly appreciated!
I am trying to firstly get a list of subfolders within a given folder, then get a specific filename from within each subfolder (they have different names but all end with "*Mosaix.zvi)
I am having considerable trouble with this, as the first part is trivial but the second part is proving quite difficult for a VBA novice like myself!
I have approached it in 2 ways, using Dir (which crashes instantly when running) and FSO (which doesn't return the filenames at all), as follows:
Sub loopThroughAllFolders()
Dim basePath, fileSearch, fileName, folderPathString, filePathString, filePath, subFolders As String
Dim idx As Integer
basePath = "F:\Petrography Images\"
fileSearch = "*Mosaix.zvi"
idx = 0
subFolders = Dir(basePath, vbDirectory)
Do While subFolders <> ""
If subFolders <> "." And subFolders <> ".." Then
idx = idx + 1
folderPathString = basePath & subFolders & "\"
If GetAttr(folderPathString) = vbDirectory Then
filePathString = folderPathString & fileSearch
fileName = Dir(filePathString, vbDirectory)
filePath = folderPathString & fileName
End If
Cells(idx, 1).Value = subFolders
Cells(idx, 2).Value = fileName
subFolders = Dir()
End If
Loop
End Sub
and FSO:
Sub LoopSubfoldersAndFiles()
Dim fso As Object, folder As Object, subfolders As Object, allFiles As Variant
Dim MyFile As String, fileStr As String
Dim idxFolders , idxFiles As Integer
Dim folderCount As Integer
Dim arrFolders(), arrFiles() As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("F:\Petrography Images\")
Set subfolders = folder.subfolders
fileStr = "*Mosaix.zvi"
idxFolders = 0
idxFiles = 0
folderCount = subfolders.Count
If folderCount > 0 Then
ReDim arrFolders(1 To folderCount)
ReDim arrFiles(1 To folderCount)
End If
For Each subfolders In subfolders
idxFolders = idxFolders + 1
arrFolders(idxFolders) = subfolders.Name
For Each allFiles In subfolders.Files
If InStr(allFiles.Name, "*Mosaix.zvi") > 0 Then
idxFiles = idxFiles + 1
fileNames(idxFiles) = allFiles.Name
End If
Next
Next
Range("A1").Resize(folderCount).Value = Application.Transpose(arrFolders)
Range("B1").Resize(idxFiles).Value = Application.Transpose(fileNames)
Set fso = Nothing
Set folder = Nothing
Set subfolders = Nothing
End Sub
Any help in solving this would be greatly appreciated!