Copy all inactive workbooks/sheets to single worksheet

dappy

Board Regular
Joined
Apr 23, 2018
Messages
109
Office Version
  1. 2013
Platform
  1. Windows
morning guru's

This is more a stab in the dark to see if its possible. If I have a folder with a random amount of sheets in with each sheet a random amount if populated rows in is it possible to copy all rows from all sheets into one sheet?

Sounds a lot to ask and my searches have come up empty so not sure it can be done.

Any views much appreciated
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
Try the following, change in the macro, the name of the folder and the name of your sheet that will receive the data

Rich (BB code):
  Set sh1 = ThisWorkbook.Sheets("One sheet")
  sPath = "C:\Folder\books\"



VBA Code:
Sub ScrapingMultipleWorkbooks()
  Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
  Dim sPath As String, sFile As String, f As Range
  Dim lr1 As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = ThisWorkbook.Sheets("One sheet")
  sPath = "C:\Folder\books\"
  sFile = Dir(sPath & "*.xls*")
  sh1.Cells.ClearContents
  
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPath & sFile)
    For Each sh2 In wb2.Sheets
      Set f = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
      If Not f Is Nothing Then lr1 = f.Row + 1 Else lr1 = 1
      Set f = sh2.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
      If Not f Is Nothing Then lr2 = f.Row Else lr2 = 1
      sh2.Range("A1:A" & lr2).EntireRow.Copy sh1.Range("A" & lr1)
    Next
    wb2.Close False
    sFile = Dir()
  Loop
  
  Application.ScreenUpdating = True
End Sub
 
Solution

dappy

Board Regular
Joined
Apr 23, 2018
Messages
109
Office Version
  1. 2013
Platform
  1. Windows
matey that is superb. thanks for such a swift reply and solution. i didn't think it was possible but that's grand. thank you. you rock!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

dappy

Board Regular
Joined
Apr 23, 2018
Messages
109
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Sorry, can I add a question to that please? If all the workbooks I need to copy from have 2 sheets and I only need to copy from the second sheet is that possible? Only that the crappy laptop work has provided me with is struggling if there's more than a hundred workbooks to copy from!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
I only need to copy from the second sheet
Try this

VBA Code:
Sub ScrapingMultipleWorkbooks()
  Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
  Dim sPath As String, sFile As String, f As Range
  Dim lr1 As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = ThisWorkbook.Sheets("One sheet")
  sPath = "C:\trabajo\books\"
  sFile = Dir(sPath & "*.xls*")
  sh1.Cells.ClearContents
  
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPath & sFile)
    If wb2.Sheets.Count > 1 Then
      Set f = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
      If Not f Is Nothing Then lr1 = f.Row + 1 Else lr1 = 1
      Set f = wb2.Sheets(2).Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
      If Not f Is Nothing Then lr2 = f.Row Else lr2 = 1
      wb2.Sheets(2).Range("A1:A" & lr2).EntireRow.Copy sh1.Range("A" & lr1)
    End If
    wb2.Close False
    sFile = Dir()
  Loop
  
  Application.ScreenUpdating = True
End Sub
 

dappy

Board Regular
Joined
Apr 23, 2018
Messages
109
Office Version
  1. 2013
Platform
  1. Windows
Perfect, Once again, superb. thank you so much, that's spot on.

Thank you!
 

Watch MrExcel Video

Forum statistics

Threads
1,130,119
Messages
5,640,218
Members
417,131
Latest member
Seanr19871

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
Top