Open Multiple excel workbooks and paste into the new

[babar2019]

Hello,

I have different excel workbooks in the multiple locations and would like to open them and copy into a new excel.

Example,

This is the standard location - C:\IT\Test Project\2019
Further the 2019 is divided into 12 monthly folders named 1-2019, 2-2019, 3-2019 etc.

Each of the monthly folder consists of an excel names Test ALL - Jan - 2019, Test ALL - Feb - 2019, Test ALL - Mar - 2019 etc.

I would like macro to open each at once and copy the data into a new excel. Eventually I'd end up with one file which has the 12 month's data.

This process should only repeat until the current month. In this case it should just end at 8-2019 folder and stop.

Thank you

 

[DanteAmor]

Some details:
- Name of the sheet with data to be copied?
- Is the information copied and pasted on a single sheet, or would the new book end with 12 sheets?

 

[babar2019]

Hello,

The name of the Sheet is called Esquire-All
Yes, the info should be copy/pasted into single sheet.

Thank you

 

[DanteAmor]

Try this

Sub Open_Multiple_workbooks()
  Dim wPath As String, wYear As String, fso As Object
  Dim wFolder As Object, wSubfolder As Object, wFile As Object
  Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
  Dim lr1 As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  wYear = "2019"
  wPath = "[COLOR=#0000ff]C:\IT\Test Project\[/COLOR]" & wYear
  If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
  
  Set wb1 = Workbooks.Add
  Set sh1 = wb1.Sheets(1)
  Set fso = CreateObject("scripting.filesystemobject")
  Set wFolder = fso.getfolder(wPath)
  For Each wSubfolder In wFolder.subfolders
    For Each wFile In wSubfolder.Files
      Set wb2 = Workbooks.Open(wFile)
      Set sh2 = wb2.Sheets(1)
      lr1 = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row + 1
      lr2 = sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row
      sh2.Rows("1:" & lr2).Copy
      sh1.Range("A" & lr1).PasteSpecial xlPasteValues
      wb2.Close False
    Next
  Next
  
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub