VBA listing folders, sub-folders & file names - modification required

C

cjcass

Well-known Member
Joined
Oct 27, 2011
Messages
679
Office Version
  1. 2016
Platform
  1. Windows
Hi,
I have the VBA below which extracts folders, sub-folders & file names from a specified parent folder and drops them into Excel. The code is excellent and works well but I'm wondering how can it be modified so it only lists files with specific associations? For example; initially I only want to retrieve filenames in the folders that have the associations .mp3 and .flac with all the folders being retrieved as normal. I would like to be able to identify these associations in the code and change them when required to say .jpg .xlsm etc.
Any help much appreciated.
VBA Code: 
Option Explicit

Public Sub Main_List_Folders_and_Files()

    Dim startFolderPath As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If Not .Show Then
            MsgBox "User cancelled"
            Exit Sub
        End If
        startFolderPath = .SelectedItems(1)
    End With

    With ActiveSheet
        .Cells.Clear
        List_Folders_and_Files startFolderPath, .Range("A1")
    End With

End Sub


Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long

    Dim FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
    Dim folders As Collection, levels As Collection
    Dim subfoldersColl As Collection
    Dim n As Long, c As Long, i As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folders = New Collection
    Set levels = New Collection
    
    'Add start folder to stack
    
    folders.Add FSO.GetFolder(folderPath)
    levels.Add 0
      
    n = 0

    Do While folders.Count > 0
    
        'Remove next folder from top of stack
        
        Set FSfolder = folders(folders.Count): folders.Remove folders.Count
        c = levels(levels.Count): levels.Remove levels.Count
        
        'Output this folder and its files
        
        destCell.Offset(n, c).Value = "'" & FSfolder.Name
        n = n + 1
        c = c + 1
        For Each FSfile In FSfolder.Files
            destCell.Offset(n, c).Value = "'" & FSfile.Name
            n = n + 1
        Next
              
        'Get collection of subfolders in this folder
        
        Set subfoldersColl = New Collection
        For Each FSsubfolder In FSfolder.SubFolders
            subfoldersColl.Add FSsubfolder
        Next
        
        'Loop through collection in reverse order and put each subfolder on top of stack.  As a result, the subfolders are processed and
        'output in the correct ascending ASCII order
        
        For i = subfoldersColl.Count To 1 Step -1
            If folders.Count = 0 Then
                folders.Add subfoldersColl(i)
                levels.Add c
            Else
                folders.Add subfoldersColl(i), , , folders.Count
                levels.Add c, , , levels.Count
            End If
        Next
        Set subfoldersColl = Nothing
                
    Loop
    
    List_Folders_and_Files = n

End Function
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
That's some interesting code. If you have multiple file extensions to search for at once then this array approach should work. If it's only one file extension, the array would be unnecessary, but code in the same location for just one variable. HTH. Dave
Code: 
'add
Dim Arr As Variant
Arr = Array(".jpg", ".xlsm")

With ActiveSheet
.Cells.Clear
'change
List_Folders_and_Files startFolderPath, .Range("A1"), Arr
End With

'change
Private Function List_Folders_and_Files(folderPath As String, destCell As Range, InArr As Variant) As Long

For Each FSfile In FSfolder.Files
'add
For cnt = LBound(InArr) To UBound(InArr)
If InStr(FSfile.Name, InArr(cnt)) Then
destCell.Offset(n, c).Value = "'" & FSfile.Name
n = n + 1
Exit For
End If
Next cnt
Next
 
Upvote 0
NdNoviceHlp said:
That's some interesting code. If you have multiple file extensions to search for at once then this array approach should work. If it's only one file extension, the array would be unnecessary, but code in the same location for just one variable. HTH. Dave
Code: 
'add
Dim Arr As Variant
Arr = Array(".jpg", ".xlsm")

With ActiveSheet
.Cells.Clear
'change
List_Folders_and_Files startFolderPath, .Range("A1"), Arr
End With

'change
Private Function List_Folders_and_Files(folderPath As String, destCell As Range, InArr As Variant) As Long

For Each FSfile In FSfolder.Files
'add
For cnt = LBound(InArr) To UBound(InArr)
If InStr(FSfile.Name, InArr(cnt)) Then
destCell.Offset(n, c).Value = "'" & FSfile.Name
n = n + 1
Exit For
End If
Next cnt
Next
Click to expand...
Hi,
Many thanks for your response.
I'm not advanced with VBA and have tried placing these elements into the existing code but with no luck - can you place them into the correct position in the code so I know exactly where they go, thanks for your help.
 
Upvote 0
You can trial this....
Code: 
Option Explicit

Public Sub Main_List_Folders_and_Files()

    Dim startFolderPath As String
'add
Dim Arr As Variant
'change file extensions to suit
Arr = Array(".jpg", ".xlsm")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If Not .Show Then
            MsgBox "User cancelled"
            Exit Sub
        End If
        startFolderPath = .SelectedItems(1)
    End With

    With ActiveSheet
        .Cells.Clear
        'List_Folders_and_Files startFolderPath, .Range("A1")
        'change
        List_Folders_and_Files startFolderPath, .Range("A1"), Arr
    End With

End Sub

'change
Private Function List_Folders_and_Files(folderPath As String, destCell As Range, InArr As Variant) As Long
'Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long

    Dim FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
    Dim folders As Collection, levels As Collection
    Dim subfoldersColl As Collection
    Dim n As Long, c As Long, i As Long, Cnt As Integer
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folders = New Collection
    Set levels = New Collection
    
    'Add start folder to stack
    
    folders.Add FSO.GetFolder(folderPath)
    levels.Add 0
      
    n = 0

    Do While folders.Count > 0
    
        'Remove next folder from top of stack
        
        Set FSfolder = folders(folders.Count): folders.Remove folders.Count
        c = levels(levels.Count): levels.Remove levels.Count
        
        'Output this folder and its files
        
        destCell.Offset(n, c).Value = "'" & FSfolder.Name
        n = n + 1
        c = c + 1
For Each FSfile In FSfolder.Files
'add
For Cnt = LBound(InArr) To UBound(InArr)
If InStr(FSfile.Name, InArr(Cnt)) Then
destCell.Offset(n, c).Value = "'" & FSfile.Name
n = n + 1
Exit For
End If
Next Cnt
Next FSfile
        'For Each FSfile In FSfolder.Files
        '    destCell.Offset(n, c).Value = "'" & FSfile.Name
         '   n = n + 1
        'Next
              
        'Get collection of subfolders in this folder
        
        Set subfoldersColl = New Collection
        For Each FSsubfolder In FSfolder.SubFolders
            subfoldersColl.Add FSsubfolder
        Next
        
        'Loop through collection in reverse order and put each subfolder on top of stack.  As a result, the subfolders are processed and
        'output in the correct ascending ASCII order
        
        For i = subfoldersColl.Count To 1 Step -1
            If folders.Count = 0 Then
                folders.Add subfoldersColl(i)
                levels.Add c
            Else
                folders.Add subfoldersColl(i), , , folders.Count
                levels.Add c, , , levels.Count
            End If
        Next
        Set subfoldersColl = Nothing
                
    Loop
    
    List_Folders_and_Files = n

End Function
 
Upvote 0
Solution
NdNoviceHlp said:
You can trial this....
Code: 
Option Explicit

Public Sub Main_List_Folders_and_Files()

    Dim startFolderPath As String
'add
Dim Arr As Variant
'change file extensions to suit
Arr = Array(".jpg", ".xlsm")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If Not .Show Then
            MsgBox "User cancelled"
            Exit Sub
        End If
        startFolderPath = .SelectedItems(1)
    End With

    With ActiveSheet
        .Cells.Clear
        'List_Folders_and_Files startFolderPath, .Range("A1")
        'change
        List_Folders_and_Files startFolderPath, .Range("A1"), Arr
    End With

End Sub

'change
Private Function List_Folders_and_Files(folderPath As String, destCell As Range, InArr As Variant) As Long
'Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long

    Dim FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
    Dim folders As Collection, levels As Collection
    Dim subfoldersColl As Collection
    Dim n As Long, c As Long, i As Long, Cnt As Integer
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folders = New Collection
    Set levels = New Collection
   
    'Add start folder to stack
   
    folders.Add FSO.GetFolder(folderPath)
    levels.Add 0
     
    n = 0

    Do While folders.Count > 0
   
        'Remove next folder from top of stack
       
        Set FSfolder = folders(folders.Count): folders.Remove folders.Count
        c = levels(levels.Count): levels.Remove levels.Count
       
        'Output this folder and its files
       
        destCell.Offset(n, c).Value = "'" & FSfolder.Name
        n = n + 1
        c = c + 1
For Each FSfile In FSfolder.Files
'add
For Cnt = LBound(InArr) To UBound(InArr)
If InStr(FSfile.Name, InArr(Cnt)) Then
destCell.Offset(n, c).Value = "'" & FSfile.Name
n = n + 1
Exit For
End If
Next Cnt
Next FSfile
        'For Each FSfile In FSfolder.Files
        '    destCell.Offset(n, c).Value = "'" & FSfile.Name
         '   n = n + 1
        'Next
             
        'Get collection of subfolders in this folder
       
        Set subfoldersColl = New Collection
        For Each FSsubfolder In FSfolder.SubFolders
            subfoldersColl.Add FSsubfolder
        Next
       
        'Loop through collection in reverse order and put each subfolder on top of stack.  As a result, the subfolders are processed and
        'output in the correct ascending ASCII order
       
        For i = subfoldersColl.Count To 1 Step -1
            If folders.Count = 0 Then
                folders.Add subfoldersColl(i)
                levels.Add c
            Else
                folders.Add subfoldersColl(i), , , folders.Count
                levels.Add c, , , levels.Count
            End If
        Next
        Set subfoldersColl = Nothing
               
    Loop
   
    List_Folders_and_Files = n

End Function
Click to expand...
Brilliant!
That works perfectly.
Many thanks indeed for your time and helping me with this, much appreciated :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA Folder Structure -- Loop Once
Replies
2
Views
462
cwhaley1
C
O
  • Question
VBA Modification: criteria on two subfolder to open
Replies
0
Views
203
OrangeYellow
O
D
  • Solved
VBA to provide links to Folders, sub folders and files
Replies
2
Views
686
davidalldred
D
T
  • Question
help with disseminating this VBA code
Replies
4
Views
413
TroyBarnes17
T
T
  • Question
Copy and Rename files
Replies
3
Views
276
Domenic
D

Forum statistics

Threads
1,215,077
Messages
6,122,992
Members
449,094
Latest member
masterms

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top