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
I want to like to add some contribution in this website.
Can i connect you via email ?
My email ID is [email protected]
Are there any microsoft reference libraries we have to check before this code can run?
Hello Dinesh
I have used your exact code to try to loop through files in multiples subfolders. I have been unsuccessful and I’m wondering if you could proofread my code? The code seems to be failing on line: For Each myItem In collSubFolders.
To further explain my goal: I am trying to loop though a folder with subfolders for every year from 2012 – 2018. Within these 6 folders are multiple files, and I want to only files with names: 1157, 1135, 1190, 1153 so I have tried setting myFile = Dir(myFolder & myItem & “\11*.xls*”). In each one of these files, I want to only access worksheets with month names (“January -> December”). This is very complicated, and I have made a lot of progress with your code, but I need your help getting all the way there. Could you help me? If you are willing to help, the deadline for this project is this Wednesday.
Sub Non_Equine_Data()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim myFolder As String, mySubFolder As String, myFile As String, Month As String, Year As String
Dim collSubFolders As New Collection
Dim WSNameMonth As Variant, myItem As Variant, i As Variant
WSNameMonth = Array(“January”, “February”, “March”, “April”, “May”, “June”, “July”, “August”, “September”, “October”, “November”, “December”)
Dim ANKRows As Integer, ANKCols As Integer, SYMCol As Integer
Dim LastRow As Long
Dim DataAnchor As Range, DestinationCell As Range
Dim Dest As Workbook, wkb As Workbook
Set Dest = Workbooks.Open(FileName:= _
“S:\ “FilePath for destination worksheet” ” _
, UpdateLinks:=0)
myFolder = “S:\ “FolderPath” \”
mySubFolder = Dir(FolderPath & “*”, vbDirectory)
Do While mySubFolder “”
Select Case mySubFolder
Case “.”, “..”
Case Else
collSubFolders.Add Item:=mySubFolder
End Select
mySubFolder = Dir
Loop
For Each myItem In collSubFolders
myFile = Dir(myFolder & myItem & “\11*.xls*”)
Do While myFile “”
Set wkb = Workbooks.Open(FileName:=myFolder & myItem & “\” & myFile, UpdateLinks:=0)
For i = 0 To 11
Sheets(WSNameMonth(i)).Select
”””’CODE: copy and paste data to a database”””
Next i
ActiveWorkbook.Save
ActiveWorkbook.Close
myFile = Dir()
Loop
Next myItem
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
hi Dinesh
How can I assign different passwords to all the excel workbooks in the folder? let say for file path in Cell B2 should be assigned with password in C2 file path in Cell B3 should be assigned with password in C3…etc
file name file path Password
101 C:\user\vba\myproject.xlsx 111
102 C:\user\vba\myproject2.xlsx 213
103 C:\user\vba\myproject3.xlsx 987
I found most of the VBA codes available are mainly related to assign one single password to all the file under the same folder, but I got over 1000 files need to be assigned with different passwords, can it be done by VBA
Thank you sir, what if I’m looping in a folder-sub folder-sub folder? Can I add one more sub folder code? For example: folder- each borrower folder- application folder