How to modify current looping directory program to include subfolders

**1SLwLS1** · 04-15-2010, 05:13 PM

I am trying to loop through a directory, "U:\bsides\Quotes\BUYERS GUIDE\", and as it stands, I have to specify the subfolder and since there are 5 that contain "*.xlsx" file extensions, I have to this long list of code, 5X as long as it needs to be, referencing each different subfolder as the path. I have essentially just copy and pasted the same code 5 times, changing the path for each. In the future, there may be more than 5 subfolders, so I was wondering what do I need to add to include the search of subfolders.

Here is the code:

Sub DirLoop()

      'Setting up variables
      Const sPathC  As String = "U:\bsides\Quotes\BUYERS GUIDE\Contactors-Regens\"
      Const sPathF  As String = "U:\bsides\Quotes\BUYERS GUIDE\Filter Separators\"
      Const sPathH  As String = "U:\bsides\Quotes\BUYERS GUIDE\Heaters\"
      Const sPathS  As String = "U:\bsides\Quotes\BUYERS GUIDE\Separators\"
      Const sPathT  As String = "U:\bsides\Quotes\BUYERS GUIDE\Treaters\"
      Dim wkb       As Workbook
      Dim sFile     As String
      Dim CountC    As Integer
      Dim CountF    As Integer
      Dim CountH    As Integer
      Dim CountS    As Integer
      Dim CountT    As Integer
      Dim rngFind As Range, firstAddress As String
      Dim n As Integer - For that random formatting
      Dim sCellmat As String - For that random formatting
      Dim sCelllab As String - For that random formatting
      Dim sCellacc As String - For that random formatting
      'Disables Alerts
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      Application.EnableEvents = False
      'Set up path and directory
      sFile = Dir(sPathC & "*.xlsx")
      'Set up Count
      CountC = 0
      'Starts the loop
      Do While sFile <> ""
          Set wkb = Workbooks.Open(sPathC & sFile)
                Bunch of random formatting and search code
                'Change sheet name to default
                ActiveSheet.Name = "MasterReference"
                'Save and close workbook
                wkb.Close SaveChanges:=True
                'Adding to count
                CountC = CountC + 1
            sFile = Dir()
      Loop
      'Set up path and directory
      sFile = Dir(sPathF & "*.xlsx")
      'Set up Count
      CountF = 0
      'Starts the loop
      Do While sFile <> ""
          Set wkb = Workbooks.Open(sPathF & sFile)
                Bunch of random formatting and search code
                'Change sheet name to default
                ActiveSheet.Name = "MasterReference"
                'Save and close workbook
                wkb.Close SaveChanges:=True
                'Adding to count
                CountF = CountF + 1
            sFile = Dir()
      Loop
      'Set up path and directory
      sFile = Dir(sPathH & "*.xlsx")
      'Set up Count
      CountH = 0
      'Starts the loop
      Do While sFile <> ""
          Set wkb = Workbooks.Open(sPathH & sFile)
                Bunch of random formatting and search code
                'Change sheet name to default
                ActiveSheet.Name = "MasterReference"
                'Save and close workbook
                wkb.Close SaveChanges:=True
                'Adding to count
                CountH = CountH + 1
            sFile = Dir()
      Loop
      'Set up path and directory
      sFile = Dir(sPathS & "*.xlsx")
      'Set up Count
      CountS = 0
      'Starts the loop
      Do While sFile <> ""
          Set wkb = Workbooks.Open(sPathS & sFile)
                Bunch of random formatting and search code
                'Change sheet name to default
                ActiveSheet.Name = "MasterReference"
                'Save and close workbook
                wkb.Close SaveChanges:=True
                'Adding to count
                CountS = CountS + 1
            sFile = Dir()
      Loop
      'Set up path and directory
      sFile = Dir(sPathT & "*.xlsx")
      'Set up Count
      CountT = 0
      'Starts the loop
      Do While sFile <> ""
          Set wkb = Workbooks.Open(sPathT & sFile)
                Bunch of random formatting and search code
                'Change sheet name to default
                ActiveSheet.Name = "MasterReference"
                'Save and close workbook
                wkb.Close SaveChanges:=True
                'Adding to count
                CountT = CountT + 1
            sFile = Dir()
      Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "FillIn is complete." & vbCrLf & CountC & " Contactor files processed." _
        & vbCrLf & CountF & " Filter Separator files processed." _
        & vbCrLf & CountH & " Heater files processed." _
        & vbCrLf & CountS & " Separator files processed." _
        & vbCrLf & CountT & " Treater files processed.", _
        vbInformation + vbOKOnly + vbMsgBoxHelpButton, "Execution of FillIn"
Count = 0
End Sub

This works fine for now, just if I add subfolders, I have to copy and paste more code, and I figured there is probably an easier way to do this.

**1SLwLS1** · 04-15-2010, 05:18 PM

Just as reference, that "bunch of random formatting and search code" is over 200 lines each.

**broro183** · 04-15-2010, 08:16 PM

hi,

I haven't gone through your code but I have working code that loops through sub-folders. I use occasionally & it works well for me so hopefully you can modify it to incorporate your formatting code (instead of it creating a list of files on a new sheet). Here it is - unmodified, so you'll need to modify the "guts" of the GetFiles macro...

Option Explicit
'http://excel.tips.net/Pages/T002285_Displaying_the_Last_Modified_Date.html
'This module of macros uses the technique of recursion to examine the contents of a folder structure no matter how complex it is.
'sourced (& then modified) from http://homepage.ntlworld.com/martin.rice1/book1.xls on the following site _
 http://homepage.ntlworld.com/martin.rice1/example_of_automated_spreadsheet.htm
'other info has been used sourced from _
 http://www.erlandsendata.no/english/index.php?d=envbafolderslistfoldersscripting _
 http://www.erlandsendata.no/english/index.php?d=envbafolderslistfilesscripting
'Sub GetFiles() ' sourced  from http://excelforum.com/showthread.php?t=492643&highlight=listing+file+names
'GetFolder is sourced from p 370 & ListFiles sourced from p769 of Excel 2002 Power Programming with VBA
'*** If the macros in this module do not work, please read the following line as the instruction may allow the macros to work.
'Microsoft Scripting Runtime is included in these products: Windows98, Windows2000, IE5, and Office2000. _
 The macro examples below assumes that your VBA project has added a reference to the Microsoft Scripting Runtime library. _
 You can do this from within the VBE by selecting the menu Tools, References and selecting Microsoft Scripting Runtime.
Public FirstTimeListingSubFolders As Boolean
Public ListSubFolders As VbMsgBoxResult
Public ListAllDetails As VbMsgBoxResult
Public fs As Object, f As Object
Sub ListFilesAndFolders()
Dim RequestedDirectory As String
Dim N As Long
Dim ConvertToHyperlinks As VbMsgBoxResult
    Application.ScreenUpdating = False
    'insert & name a new sheet
    Sheets.Add
    ActiveSheet.Name = "List of Files"
    'identify if all details are required to be listed - this will be slower.
    ListAllDetails = MsgBox("Press [yes] to list all details or [no] for just the file & folder names", vbYesNo)
    Cells(5, 1) = "Folder"
    Cells(5, 2) = "File"
    Select Case ListAllDetails
        Case Is <> vbYes
            'leave blank
        Case Is = vbYes
            Cells(5, 3) = "Size"
            Cells(5, 4) = "Type"
            Cells(5, 5) = "Date Created"
            Cells(5, 6) = "Date Last Accessed"
            Cells(5, 7) = "Date Last Modified"
            Cells(5, 8) = "Attributes"
    End Select
    'GetFolder is sourced from p 370 & ListFiles sourced from p769 of Excel 2002 Power Programming with VBA
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = CurDir
        .title = "Please choose folder to list files from"
        .Show
        If .SelectedItems.Count = 0 Then MsgBox "no folder selected": Exit Sub
        RequestedDirectory = .SelectedItems(1)
    End With
    'gather user input at start of macro
    ListSubFolders = MsgBox("Do you want to list the files in the sub folders?", vbYesNo, "LIST THE FILES IN THE SUB FOLDERS?")
    ConvertToHyperlinks = MsgBox("do you want to convert the files listed to hyperlinks?", vbYesNo)
    ''The GetSubDirectories subroutine is called recursively using the name of the parent folder.
    Call GetSubDirectories(RequestedDirectory, ListSubFolders)
    ''Hyperlinks (formulae not just cell formatting using [ctrl + k] due to occassional issues) are added to all entries in columns 1 & 2
    ''other background info 3/4's down the following sheet http://www.mvps.org/dmcritchie/excel/sheets.htm
    ''Q: can this be done in one hit w/o looping?
    ''A: appears not!
    Select Case ConvertToHyperlinks
        Case Is <> vbYes
            'no action
        Case Is = vbYes
            For N = 6 To Cells(Rows.Count, 1).End(xlUp).Row
                With Cells(N, 1)
                    .Value = "=hyperlink(" & Chr(34) & .Value & Chr(34) & ", " & Chr(34) & .Value & Chr(34) & ")"
                    With .Offset(0, 1)
                        .Value = "=hyperlink(" & Chr(34) & .Value & Chr(34) & ", " & Chr(34) & .Value & Chr(34) & ")"
                    End With
                End With
            Next N
    End Select
    Columns.AutoFit
    Application.ScreenUpdating = True
    Set fs = Nothing
    Set f = Nothing
    MsgBox "done"
End Sub
Sub GetSubDirectories(folderspec, ListSubFolders As VbMsgBoxResult)
    Application.ScreenUpdating = False
    Dim SubFolder        'not sure what this sould be?
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Call GetFiles(f.path, ListAllDetails)
    Select Case ListSubFolders
        Case Is = vbYes        'value = 6
            For Each SubFolder In f.SubFolders
                Call GetSubDirectories(SubFolder.path, ListSubFolders)        'This is a recursive call
            Next SubFolder
        Case Else        'case is = 7 'vbno or False or Case Is = 2 'vbcancel or Cancelled
    End Select
End Sub
Sub GetFiles(folderspec, ListAllDetails As VbMsgBoxResult)
Dim r As Long
Dim file        'not sure what this should be?
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    For Each file In f.Files
        On Error Resume Next
        r = Range("A" & Rows.Count).End(xlUp).Row + 1
        Cells(r, 1) = folderspec
        Cells(r, 2) = folderspec & "\" & file.Name
        Select Case ListAllDetails
            Case Is <> vbYes
                'leave blank
            Case Is = vbYes
                Cells(r, 3) = file.Size
                Cells(r, 4) = file.Type
                Cells(r, 5) = file.DateCreated
                Cells(r, 6) = file.DateLastAccessed
                Cells(r, 7) = file.DateLastModified
                Cells(r, 8) = file.Attributes
        End Select
        On Error GoTo 0
        Application.ScreenUpdating = False
    Next file
    Application.ScreenUpdating = False
End Sub

hth
Rob