It's not include the header, how to include it?If they are formal Excel tables (ListObjects) then try this with a copy of your workbook. It should create a new worksheet before all the other worksheets and build the combined table on that new worksheet.
I'm assuming at most one table on each worksheet.
VBA Code:Sub CombineTables() Dim i As Long Sheets.Add Before:=Sheets(1) For i = 2 To Sheets.Count With Sheets(i) If .ListObjects.Count > 0 Then If Sheets(1).UsedRange.Address = "$A$1" Then .ListObjects(1).Range.Copy Destination:=Sheets(1).Range("A1") Else .ListObjects(1).DataBodyRange.Copy Destination:=Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1) End If End If End With Next i End Sub
Yes, because the header is also a data...It should include the header just once at the top of the new sheet.
Do you mean that you want the headers re-copied with every table?
Sounds a bit unusual but let's see if this does what you want then?Yes, because the header is also a data...
Sub CombineTables_v2()
Dim i As Long
Sheets.Add Before:=Sheets(1)
For i = 2 To Sheets.Count
With Sheets(i)
If .ListObjects.Count > 0 Then .ListObjects(1).Range.Copy Destination:=Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
Next i
Sheets(1).Rows(1).Delete
End Sub
It's took all my resources, LOL, with my old lappy, it's cannot execute, may be I'll try with dekstop.Sounds a bit unusual but let's see if this does what you want then?
VBA Code:Sub CombineTables_v2() Dim i As Long Sheets.Add Before:=Sheets(1) For i = 2 To Sheets.Count With Sheets(i) If .ListObjects.Count > 0 Then .ListObjects(1).Range.Copy Destination:=Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1) End With Next i Sheets(1).Rows(1).Delete End Sub
With desktop i5 9th generation, my desktop hang and restart. It's working with several table only (I create another file), not for all 145 table (original file).It should not take any more resources than the post 24 code to which you said
Sub CombineTables_v3()
Dim i As Long
Sheets.Add Before:=Sheets(1)
For i = 2 To Sheets.Count
With Sheets(i)
If .ListObjects.Count > 0 Then
.ListObjects(1).Range.Copy
Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
End If
End With
Next i
Sheets(1).Rows(1).Delete
End Sub