Macro to run on files in sub-folders

[dinunan]

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!

 

[dinunan]

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.

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

 

[dinunan]

Somebody please help!

 

[Fluff]

How about

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]

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]

How about

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]

That's working perfect!

Thanks a lot once again!!

 

[Fluff]

Glad to help & thanks for the feedback

 

[dinunan]

Hi Fluff

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

 

[dinunan]

Please ignore above post. My mistake - did not correct address in the code.