Copy all inactive workbooks/sheets to single worksheet

[dappy]

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

 

[DanteAmor]

Try the following, change in the macro, the name of the folder and the name of your sheet that will receive the data

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

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

 

[dappy]

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]

I'm glad to help you. Thanks for the feedback.

 

[dappy]

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]

I only need to copy from the second sheet

Try this

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]

Perfect, Once again, superb. thank you so much, that's spot on.

Thank you!

 

[DanteAmor]

You are welcome!