combine multiple workbooks first sheet start at row 2 and appending to the bottom

[jordanburch]

Hey guys

been trying different codes most of the day. Have not found anything that would work. I would like it to combine multiple spreadsheets starting with the name Phase1. I would then like it to create a column with the file title name to the left to remeber which file the record came from. I also would like it to start on row 2. I have had some success but nothing seems to pop up with everything I need. Can anyone help?

Jordan

 

[jordanburch]

ok so update. Been working on this still

Sub combine_multiple_workbooks()
Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim sFile As Variant, sPath As String, LastRow1 As Long, LastRow2 As Long
Dim sh As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wb1 = ThisWorkbook
Set sh1 = wb1.Sheets("Summary")
sh1.Cells.ClearContents
sh1.Range("A1").Value = "File"
sPath = "C:\Users\jordan.burch.ctr\Desktop\TEST\"
sFile = Dir(sPath & "Phase1*.xls*")

Do While sFile <> ""
Set wb2 = Workbooks.Open(sPath & sFile)


For Each sh In wb2.Sheets
If sh.Visible = -1 Then
Set sh2 = wb2.Sheets(1)

Exit For
End If
Next
LastRow2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.ShowAllData
LastRow1 = sh1.Range("B" & Rows.Count).End(xlUp).Row + 1

sh2.Range("A2:AE" & LastRow2).Copy
sh1.Range("B" & LastRow1).PasteSpecial xlPasteAll
sh1.Range("A" & LastRow1).Resize(LastRow2 - 0)"this is where it was erroring out on, I changed the 1 to a 0".Value = sFile

wb2.Close False
sFile = Dir()
Loop
End Sub

I still need help opening the spreadsheets and unfiltering all the data so it can copy all the data. Could you please help with with that Dante?

 

[DanteAmor]

Try this

Sub combine_multiple_workbooks()
  Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
  Dim sFile As Variant, sPath As String, LastRow1 As Long, LastRow2 As Long
  Dim sh As Worksheet
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set wb1 = ThisWorkbook
  Set sh1 = wb1.Sheets("Summary")
  sh1.Cells.ClearContents
  sh1.Range("A1").Value = "File"
  sPath = "C:\Users\jordan.burch.ctr\Desktop\TEST\"
  sFile = Dir(sPath & "Phase1*.xls*")
  
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPath & sFile)
    For Each sh In wb2.Sheets
      If sh.Visible = -1 Then
      Set sh2 = wb2.Sheets(1)
      Exit For
      End If
    Next
    On Error Resume Next
    sh2.ShowAllData
    On Error GoTo 0
    LastRow2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
    LastRow1 = sh1.Range("B" & Rows.Count).End(xlUp).Row + 1
    
    sh2.Range("A2:AE" & LastRow2).Copy
    sh1.Range("B" & LastRow1).PasteSpecial xlPasteAll
    sh1.Range("A" & LastRow1).Resize(LastRow2 - 0).Value = sFile
    
    wb2.Close False
    sFile = Dir()
  Loop
End Sub

 

[jordanburch]

awesome thanks bud for your patience and help through all of this I have learned a ton. Now I just gotta figure out how to deal with these corrupt files it seems and thats it.

 

[DanteAmor]

Glad we could help & thanks for the feedback