How to Loop through Sub-Folders of a folder automatically using VBA and perform actions on the workbooks. We have already learnt how to loop through files in a folder. Often we may need to loop through sub-folders in a folder, select data in a specific sheet and transfer it to another workbook where we can consolidate the data.

Watch the video below:

 

Watch this video on YouTube.

Here’s the complete VBA code:

Sub LoopFolders()
Dim myFolder As String
Dim mySubFolder As String
Dim myFile As String
Dim collSubFolders As New Collection
Dim myItem As Variant
Dim wbk As Workbook

‘ set parent folder with trailing backslash

myFolder = “C:\Projects\”
‘Retrieve first sub-folder
mySubFolder = Dir(myFolder & “*”, vbDirectory)

Application.ScreenUpdating = False

‘Do While Not mySubFolder = “”
Do While mySubFolder <> “”
Select Case mySubFolder
Case “.”, “..”

‘ ignore current folder or parent folder

Case Else
‘ Add to collection called collSubFolders
‘collSubFolders.Add Item:=mySubFolder, Key:=mySubFolder
collSubFolders.Add Item:=mySubFolder

End Select

‘ Get next entry

mySubFolder = Dir
Loop

‘ Loop through the collection
For Each myItem In collSubFolders

‘ Loop through Excel workbooks in subfolder

myFile = Dir(myFolder & myItem & “\*.xls*”)

 

Do While myFile <> “”

‘ Open workbook

Set wbk = Workbooks.Open(Filename:=myFolder & myItem & “\” & myFile)

‘ Copy data from the opened workbook

lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
ActiveSheet.Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy
‘ Close opened workbook without saving any changes
wbk.Close SaveChanges:=False
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
Application.CutCopyMode = False
myFile = Dir
Loop
Next myItem
Application.ScreenUpdating = True
End Sub