Macro to run on files in sub-folders

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
Hi All
I've daily reports stored in multiple folders. Folder structure is like Reports/2018/01.Jan-2018/01-01-2018/two files (*.xls). Likewise for each day of the month (two files). Now I want to create one Monthly Average file residing in 01.Jan-2018 (Month Folder). I want to have a macro to run through each folder (day wise) and copy range J5:J250 of one file in monthly average file sheet1 and similar range from second file in that folder to again in Monthly average file sheet2. The next day files should update on left hand side in average file. This will bring all the data in one file and I'll be able to analyze the data in a single file.

Thanks for help!
 

Some videos you may like

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
Found some code in other threads and modified but it is working for 1st file but not doing anything on 2nd file in the folder. Also not moving to the next folder.
Need help.

Code:
Sub MonthlyAverage()


Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
Dim wb As ThisWorkbook


ThisWorkbook.Worksheets(1).Range("E4").Activate


FromPath = "C:\Reports\Year\06.June 2018"
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)


For Each objSubFolder In objFolder.subfolders
    For Each FileInFolder In objSubFolder.Files


 If InStr(1, FileInFolder.Name, ".xls") Then
 Application.AskToUpdateLinks = False
 Application.DisplayAlerts = False
 
Workbooks.Open FileInFolder

Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
 
With Worksheets(1)
Set Rng = .Range("J5:J250")
Rng.Copy
ThisWorkbook.Activate
ActiveCell.Offset(0, 0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ActiveCell.Offset(0, 1).Activate
ThisWorkbook.Worksheets(2).Activate
Range("E4").Activate


End With




With Worksheets(1)
Set Rng = .Range("J5:J250")
Rng.Copy
ThisWorkbook.Activate
ActiveCell.Offset(0, 0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ActiveCell.Offset(0, 1).Activate


End With


ActiveWorkbook.Close True


 
 
  'Next FileInFolder
'Next objSubFolder




End If
Next
Next
End Sub
 
Last edited by a moderator:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,764
Office Version
365
Platform
Windows
How about
Code:
Sub MonthlyAverage()
   Dim Fso As Object, objFolder As Object, objSubFolder As Object
   Dim FromPath As String
   Dim FileInFolder As Object
   Dim Wb As Workbook
   Dim Mwb As Workbook
   Dim rng As Range
   Dim c As Long
   
   Set Mwb = ThisWorkbook
   FromPath = "C:\Reports\Year\06.June 2018"
   Set Fso = CreateObject("Scripting.filesystemobject")
   Set objFolder = Fso.getfolder(FromPath)
   c = 5
   
   For Each objSubFolder In objFolder.subfolders
      For Each FileInFolder In objSubFolder.Files
         If InStr(1, FileInFolder.name, ".xls") Then
            Application.AskToUpdateLinks = False
            Application.DisplayAlerts = False
            
            Set Wb = Workbooks.Open(FileInFolder)
            
            Application.AskToUpdateLinks = False
            Application.DisplayAlerts = False
            
            Wb.Worksheets(1).Range("J5:J250").Copy
            Mwb.Sheets(1).Cells(4, c).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                  :=False, Transpose:=False
            c = c + 1
            Wb.Worksheets(2).Range("J5:J250").Copy
            Mwb.Sheets(1).Cells(4, c).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
            c = c + 1
            Wb.Close False
         End If
      Next
   Next
End Sub
 

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
Hey Fluff, Thanks again!
your code is halting at
wb.Worksheets(2).Range("J5:J250").copy
because there isn't worksheet 2 in any of the source file. So I changed it to worksheet(1) and it brings data.
But I want data from one file to paste in Mwb.Sheet(1) and from other file to Mwb.Sheet(2).
When I made those changes, code processes the files and copies the data in both sheets of Mwb. No segregation of data.
Also it adds one blank column between two entries.
Please suggest!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,764
Office Version
365
Platform
Windows
How about
Code:
Sub MonthlyAverage()
   Dim Fso As Object, objFolder As Object, objSubFolder As Object
   Dim FromPath As String
   Dim FileInFolder As Object
   Dim Wb As Workbook
   Dim Mwb As Workbook
   Dim rng As Range
   Dim c As Long, sht As Long
   
   Set Mwb = ThisWorkbook
   FromPath = "C:\Reports\Year\06.June 2018"
   Set Fso = CreateObject("Scripting.filesystemobject")
   Set objFolder = Fso.getfolder(FromPath)
   c = 5
   
   For Each objSubFolder In objFolder.subfolders
      For Each FileInFolder In objSubFolder.Files
         sht = IIf(sht = 1, 2, 1)
         If InStr(1, FileInFolder.name, ".xls") Then
            Application.AskToUpdateLinks = False
            Application.DisplayAlerts = False
            
            Set Wb = Workbooks.Open(FileInFolder)
            
            Application.AskToUpdateLinks = False
            Application.DisplayAlerts = False
            
            Wb.Worksheets(1).Range("J5:J250").Copy
            Mwb.Sheets(sht).Cells(4, c).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                  :=False, Transpose:=False
            Wb.Close False
         End If
      Next
      c = c + 1
   Next
End Sub
 

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
That's working perfect!

Thanks a lot once again!!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,764
Office Version
365
Platform
Windows
Glad to help & thanks for the feedback
 

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
Hi Fluff

Strangely the code processes only 27 folders and not all 30 or 31. Any reason?
 

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
Please ignore above post. My mistake - did not correct address in the code.
 

Watch MrExcel Video

Forum statistics

Threads
1,089,766
Messages
5,410,303
Members
403,309
Latest member
chaithra

This Week's Hot Topics

Top