Loop through directory and copy data from same tab in each

[Samson92]

I have a folder which contains various excel sheets, some xlslx and some xlsm, in each of these sheets there are multiple tabs but each one has one called 'Data'. The data starts in Column A row 6, and goes to BE6. This is consistent throughout each file in the directory, but the number of rows varies depending on the file.

What i'd like to have a master sheet which loops through every excel file in a directory ("G:\Team\Corporate\July"), opens them and goes to the 'Data' tab in each, and copies from row 6 to the last line with data, and then copies them to a tab called 'Master' in the workbook the VBA code is run from. I would like the first set of data to also be paste in row 6, so from A6:BE6, and then each subsequent time data is copied, for it to be pasted on the next empty line.

How would this best be done?

Thanks.

 

[Fluff]

How about

Sub samson92()
   Dim Mws As Worksheet
   Dim Pth As String, Fname As String
   
   Set Mws = ThisWorkbook.Sheets("Master")
   Pth = "G:\Team\Corporate\July\"
   Application.ScreenUpdating = False
   Mws.Rows("6:" & Rows.Count).Clear
   Fname = Dir(Pth & "*.xls*")
   Do While Fname <> ""
      With Workbooks.Open(Pth & Fname)
         With .Sheets("Data")
            .Range("A6:BE" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         End With
         .Close False
      End With
      Fname = Dir()
   Loop
End Sub

 

[Samson92]

Thank you, this is exactly what I need, works like a charm. Is it at all possible to alter it to run through two directories one after the other?

 

[Fluff]

Yup, like

Sub samson92()
   Dim Mws As Worksheet
   Dim Pth As String, Fname As String
   
   Set Mws = ThisWorkbook.Sheets("Master")
   Pth = "G:\Team\Corporate\July\"
   Application.ScreenUpdating = False
   Mws.Rows("6:" & Rows.Count).Clear
   Fname = Dir(Pth & "*.xls*")
   Do While Fname <> ""
      With Workbooks.Open(Pth & Fname)
         With .Sheets("Data")
            .Range("A6:BE" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         End With
         .Close False
      End With
      Fname = Dir()
   Loop
   Pth = "C:\MrExcel\"
   Fname = Dir(Pth & "*.xls*")
   Do While Fname <> ""
      With Workbooks.Open(Pth & Fname)
         With .Sheets("Data")
            .Range("A6:BE" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         End With
         .Close False
      End With
      Fname = Dir()
   Loop
End Sub

 

[Samson92]

I had it all in one loop, this works perfect. Thank you for your help.

 

[Fluff]

You're welcome & thanks for the feedback