Looping through folders

[Shiles]

I'm able to loop through all the files in a directory but what i need to do is loop through all the folders, within a folder and where that folder is called "Q2 2012" open the file within that folder and execute code.

There are several Q2 2012 folders but are all at different levels within the directory folder? The code i have below might be a distraction so happy to work from afresh. FYI it 2007 so application file search won't work!

Be very grateful for you assistance.

Sub InterlockSalesVolumeDataPull()
Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String
Dim wrk1 As Worksheet
Dim wsheet As Worksheet
Dim BothFileTypesComplete As Boolean
Dim FirstFileTypefinished As Boolean
Dim FirstSheet As Integer
Dim a As Integer
Dim FileSelect As String
Dim oSheet As Worksheet
FileSelect = ThisWorkbook.Sheets("Activity capture.").Range("c1")
a = 5
FirstSheet = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'turn off prompt messages

'sPath = "N:\Marketing Strategy Team\Quarterly CMU Submissions\Product & Channel submissions\" & FileSelect 'location of files
'sPath = "\\Fillpb3cah38214\D_MarkPlan0001$\Marketing Strategy Team\Quarterly CMU Submissions\Product & Channel submissions\" '& FileSelect
sPath = "\\Fillpb3cah38214\D_MarkPlan0001$\Marketing Strategy Team\Quarterly CMU Submissions\Product & Channel submissions\Products\Cards\"
ChDir sPath
sFil = Dir("*.xls") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
Set oWbk = Workbooks.Open(sPath & "\" & sFil, 0) 'opens the file
oWbk.Activate 'actives workbook to allow ammends to be made
Dim Brand As String
Brand = ActiveWorkbook.ActiveSheet.Name
'loop through sheets

For Each wsheet In ActiveWorkbook.Worksheets
wsheet.Activate
Dim SheetName As String
SheetName = ActiveSheet.Name
If ActiveSheet.Name <> "Cover page" Then
ThisWorkbook.Activate
Worksheets(SheetName & " Interlock Data").Delete ' remove old sheet
oWbk.Activate
Cells.Select
Cells.Copy
ThisWorkbook.Activate
'Set oSheet = Worksheets.Add
ThisWorkbook.Sheets.Add After:=Sheets(Worksheets.Count), Count:=1, Type:=xlWorksheet
With ActiveSheet
.Name = SheetName & " Interlock Data"
.Tab.Color = RGB(255, 0, 0)
End With

ActiveSheet.Paste

End If
Next wsheet
oWbk.Close 'close the workbook, saving changes
sFil = Dir
Loop ' End of LOOP
Application.DisplayAlerts = True 'turn on prompt messages
Application.ScreenUpdating = True
End Sub

 

[Jerry Sullivan]

Hi Shiles,

Below is some code you can use as a starting point to loop through a specified folder and its subfolders.

It uses the "Microsoft Scripting Runtime" Library. You might need to add a Reference to that in your VBA Editor if that's not already setup.

Copy and Paste all the code into a Standard Code Module in your main workbook.

Run the Run_Process Sub, it will call the Step_Through_Folder and Process_ActiveWorkbook1 functions as needed.

I'd suggest start by getting this to work with Process_ActiveWorkbook1, which will just show a Msgbox for each Workbook in your Q2 2012 folders.

Once you have that working you can change the Call to Process_ActiveWorkbook2 which will do the steps you want executed in each "found" workbook.

I've taken a first pass at that based on your example, but I probably misinterpreted your intent in spots, so it will need some editing.

Sub Run_Process()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Call Step_Through_Folder _
        ("N:\Marketing Strategy Team\Quarterly CMU Submissions\" _
            & "Product & Channel submissions\" _
            & Sheets("Activity capture.").Range("c1"))
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Function Step_Through_Folder(sFolderName As String)
    Dim sFilename As String
    Dim ws As Worksheet
    Dim oFSO As Scripting.FileSystemObject
    Dim oFolder As Scripting.Folder
    Dim oSubFolder As Scripting.Folder
    Dim oFileItem As Object
    
    Set oFSO = New Scripting.FileSystemObject
    Set oFolder = oFSO.GetFolder(sFolderName)
    
    If oFolder.Name = "Q2 2012" Then
        For Each oFileItem In oFolder.Files
            'Open file and execute steps
            sFilename = oFileItem.Name
            If LCase(sFilename) Like "*.xlsx" Then
                Workbooks.Open (oFolder.path & "\" & sFilename)
                Call Process_ActiveWorkbook1
            End If
        Next oFileItem
    End If
    For Each oSubFolder In oFolder.SubFolders
        Call Step_Through_Folder(oSubFolder.path)
    Next oSubFolder
    
    Set oFileItem = Nothing
    Set oFolder = Nothing
    Set oSubFolder = Nothing
    Set oFSO = Nothing
End Function

Function Process_ActiveWorkbook1()
    With ActiveWorkbook
        MsgBox "Processing: " & .path & "\" & .Name
        .Close SaveChanges:=False
    End With
End Function

Function Process_ActiveWorkbook2()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Cover page" Then
            With ThisWorkbook
                .Worksheets(ws.Name & " Interlock Data").Delete
                ws.Copy After:=.Sheets(.Sheets.Count)
                With .Sheets(.Sheets.Count)
                    .Name = ws.Name & " Interlock Data"
                    .Tab.Color = RGB(255, 0, 0)
                End With
            End With
        End If
    Next ws
End Function

 

[Shiles]

Jerry you're a star, works like a dream. Many Thanks