VBA to List items (including folders) with specific word (excel)-CodePudding

I would like to ask if there's a way for VBA to list all files (including folders/subfolders) with word OLDIES-(whatever the text or number here)

Sub ListOLDIES()
Dim FSO As Object, FSOSubFolder As Object, FileName As String
Dim FSOFile As Object, objFolder As Object, RowNum As Integer
Dim ExtSplit As Variant, NameSplit As Variant
strDirectory = "C:\Desktop\"
RowNum = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strDirectory)
For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

For Each FSOFile In objFolder.Files
If InStr(FSOFile.path, "OLDIES") Then
ExtSplit = Split(FSOFile.path, ".")
NameSplit = Split(FSOFile.path, "\")
FileName = Left(NameSplit(UBound(NameSplit)), _
           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
Flpath = Left(FSOFile.path, Len(FSOFile.path) - Len(NameSplit(UBound(NameSplit))))
ActiveSheet.Cells(RowNum, 1) = FileName & ", " & Flpath & ", ." & ExtSplit(UBound(ExtSplit))
RowNum = RowNum   1
End If
Next FSOFile
Set objFolder = Nothing
Set FSO = Nothing
End Sub

Got an error "out of stack space" using that code.

Desired result;

Name	Location	Extension
OLDIES-12345	C:Desktop	Folder
OLDER-23456	C:Desktop	.zip
OLDER-23457	C:Desktop/OLDIES_12345	.xlsx

Thanks!

CodePudding user response：

this should work:

Sub list_oldies()
    Dim FileSystem As Object
    Dim HostFolder As String
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    HostFolder = "C:\Users\salzerm.kontura\Desktop\Test\"
        
    DoFolder FileSystem.GetFolder(HostFolder), 1
End Sub
    
Sub DoFolder(folder, RowNum As Integer)
    Dim SubFolder
    Dim ExtSplit As Variant
    Dim NameSplit As Variant
    
    For Each SubFolder In folder.SubFolders
        If InStr(SubFolder, "Oldies") Then
                ExtSplit = "Folder"
                NameSplit = Split(SubFolder, "\")
                Filename = Left(NameSplit(UBound(NameSplit)), _
                           Len(NameSplit(UBound(NameSplit))) - 1)
                Flpath = Left(SubFolder, Len(SubFolder) - Len(NameSplit(UBound(NameSplit))))
                ActiveSheet.Cells(RowNum, 1) = Filename
                ActiveSheet.Cells(RowNum, 2) = Flpath
                ActiveSheet.Cells(RowNum, 3) = ExtSplit
                RowNum = RowNum   1
        End If
        
        DoFolder SubFolder, RowNum
    Next
    Dim file
    For Each file In folder.Files
        If file Like "*Oldies*.*" Then
                ExtSplit = Split(file, ".")
                NameSplit = Split(file, "\")
                Filename = Left(NameSplit(UBound(NameSplit)), _
                           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
                Flpath = Left(file, Len(file) - Len(NameSplit(UBound(NameSplit))))
                ActiveSheet.Cells(RowNum, 1) = Filename
                ActiveSheet.Cells(RowNum, 2) = Flpath
                ActiveSheet.Cells(RowNum, 3) = ExtSplit(UBound(ExtSplit))
                RowNum = RowNum   1
        End If
    Next
End Sub

CodePudding user response：

The issue is that your recursively run your procedure

For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

but because you set the start folder to strDirectory = "C:\Desktop\" with every run of the procedure it starts running endless for C:\Desktop\ and never goes into the subfolders.

If you put a Debug.Print into that loop

For Each FSOSubFolder In objFolder.subfolders
    Debug.Print FSOSubFolder.Path
    ListOLDIES
Next FSOSubFolder

You will see that it always prints the first subfolder and never goes into it. You can see that best when you run the code step by step using F8.

How to solve that issue?

So what you need to do is you need to set the start folder strDirectory to the subfolder when you recursively start your proceduer ListOLDIES again. Therefore we need to remove the strDirectory = "C:\Desktop\" add it as an argument.

Sub ListOLDIES(ByVal strDirectory As String)

And change the recourssive call to ListOLDIES FSOSubFolder.Path

If we now do a simple test using

Option Explicit

Public Sub Example()
    ListOLDIES "C:\Desktop"
End Sub

Public Sub ListOLDIES(ByVal strDirectory As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim objFolder As Object
    Set objFolder = FSO.GetFolder(strDirectory)
    
    Dim FSOSubFolder As Object
    For Each FSOSubFolder In objFolder.subfolders
        Debug.Print FSOSubFolder.Path
        ListOLDIES FSOSubFolder.Path
    Next FSOSubFolder
    
    Dim FSOFile As Object
    For Each FSOFile In objFolder.Files
        Debug.Print FSOFile.Path
    Next FSOFile
    
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub

We get a list of all (sub)folders and files of "C:\Desktop".

I used a test setup as follows:

C:\Desktop\Sub Folder 1
C:\Desktop\Sub Folder 2
C:\Desktop\Sub Folder 2\OLDIES-12345
C:\Desktop\Sub Folder 2\OLDIES-23456
C:\Desktop\Sub Folder 2\OLDIES-23456\OLDIES-12345.zip
C:\Desktop\Sub Folder 2\OLDIES-23456\OLDIES-23456.xml
C:\Desktop\Sub Folder 3
C:\Desktop\Sub Folder 3\OLDIES-12345.txt
C:\Desktop\Sub Folder 3\OLDIES-23456.txt

To maintain the RowNum counting over the entire recursive calls, you need to make that variable Static. And if you want to be able to reset it, add a parameter:

Option Explicit

Public Sub Example()
    ListOLDIES "C:\Desktop", True
End Sub

Public Sub ListOLDIES(ByVal strDirectory As String, Optional ByVal ResetRowNum As Boolean = False)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim objFolder As Object
    Set objFolder = FSO.GetFolder(strDirectory)
    
    Static RowNum As Long
    If ResetRowNum Then RowNum = 1
    
    Dim FSOSubFolder As Object
    For Each FSOSubFolder In objFolder.subfolders
        If InStr(FSOSubFolder.Name, "OLDIES") Then
            ' output folders with OLDIES
            Debug.Print RowNum, FSOSubFolder.Name & ", " & FSOSubFolder.ParentFolder.Path & "\" & ", Folder"
            RowNum = RowNum   1
        End If
        ListOLDIES FSOSubFolder.Path
    Next FSOSubFolder
    
    Dim FSOFile As Object
    For Each FSOFile In objFolder.Files
        If InStr(FSOFile.Path, "OLDIES") Then
            Dim FileExtension As String
            FileExtension = Mid$(FSOFile.Name, InStrRev(FSOFile.Name, "."))
                        
            Dim FileName As String
            FileName = Left$(FSOFile.Name, Len(FSOFile.Name) - Len(FileExtension))
                       
            Dim Flpath As String
            Flpath = FSOFile.ParentFolder.Path & "\"
            
            Debug.Print RowNum, FileName & ", " & Flpath & ", " & FileExtension
            RowNum = RowNum   1
        End If
    Next FSOFile
    
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub

So the output for my test setup would be:

 1            OLDIES-12345, C:\Desktop\Sub Folder 2\, Folder
 2            OLDIES-23456, C:\Desktop\Sub Folder 2\, Folder
 3            OLDIES-12345, C:\Desktop\Sub Folder 2\OLDIES-23456\, .zip
 4            OLDIES-23456, C:\Desktop\Sub Folder 2\OLDIES-23456\, .xml
 5            OLDIES-12345, C:\Desktop\Sub Folder 3\, .txt
 6            OLDIES-23456, C:\Desktop\Sub Folder 3\, .txt

CodePudding user response：

Please, try the next code. It is fast, more compact and returns all you required, plus the initial returned array (in column D:D):

Sub list_oldies()
   Dim arrFoldFiles, strPath As String, strSearch As String
   Dim strExt As String, arrFin, i As Long, arrName, arrExt
   
   strSearch = "Oldies"
   strExt = "*" & strSearch & "*.*"
   strPath = "C:\Desktop\"
   
   arrFoldFiles = filter(Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strPath & strExt & """ /b/s").StdOut.ReadAll, vbCrLf), "\")
    ReDim arrFin(1 To UBound(arrFoldFiles)   1, 1 To 3)
    For i = 0 To UBound(arrFoldFiles)
        arrName = Split(arrFoldFiles(i), "\")
        arrExt = Split(arrName(UBound(arrName)), ".")
            arrFin(i   1, 1) = arrExt(0)
        If UBound(arrExt) > 0 Then
             arrFin(i   1, 3) = arrExt(1)
        Else
            arrFin(i   1, 3) = "Folder"
        End If
        arrFin(i   1, 2) = left(arrFoldFiles(i), InStrRev(arrFoldFiles(i), "\"))
    Next i
    'drop the arrays content:
    Range("A1:D1").value = Array("Name", "Location", "Extension", "All")
    Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
    Range("D2").Resize(UBound(arrFoldFiles)   1, 1).value = Application.Transpose(arrFoldFiles)
    Range("A1:D1").EntireColumn.AutoFit
End Sub