Open Multiple excel workbooks and paste into the new

babar2019

Board Regular
Joined
Jun 21, 2019
Messages
93
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
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
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?
 
Upvote 0
Hello,

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

Thank you
 
Upvote 0
Try this


Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,207
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top