Sub MrE1612714_V4()
'https://www.mrexcel.com/board/threads/vba-for-copying-all-data-from-8-sheets-in-a-single-workbook-to-a-new-sheet-in-new-workbook.1220016/
'option to choose whether only first header is copied or any header as well if data is copied directly beneath
'working on CodeNames, checking for ListObject on each ws to process, let user decide via MsgBox how to go on if no ListObject
Dim ws As Worksheet
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim lngStart As Long
Dim lngCounter As Long
Dim lngOffset As Long
Dim lngAns As Long
Const clngRowsBetweenTables As Long = 2 'number of empty rows between every table on summary sheet
Const cblnHeadersOnlyOnce As Boolean = True 'True: only one Header; False: Header for every table copied
Const cblnCopyWithoutBlanks As Boolean = True 'True: directly beneath each other; False: additional blank rows between tables
If cblnCopyWithoutBlanks Then
lngOffset = 1
Else
lngOffset = 1 + clngRowsBetweenTables
End If
Set wbNew = Workbooks.Add(1)
Set wsNew = wbNew.Sheets(1)
lngStart = 1
For Each ws In ThisWorkbook.Worksheets
Select Case ws.CodeName
'change the codenames of the worksheets to suit - these are mine for the sample
Case "tblLO1", "tblLO2", "tblLO3", "tblLO4", "tblLO5", _
"tblLO6", "tblLO7", "tblLO8"
If ws.ListObjects.Count > 0 Then
lngCounter = lngCounter + 1
If lngCounter = 1 Then
ws.ListObjects(1).Range.Copy
Else
If cblnHeadersOnlyOnce Then
ws.ListObjects(1).DataBodyRange.Copy
Else
ws.ListObjects(1).Range.Copy
End If
End If
wsNew.Range("A" & lngStart).PasteSpecial xlPasteValues
lngStart = wsNew.Range("A" & Rows.Count).End(xlUp).Row + lngOffset
Else
lngAns = MsgBox("No table found on '" & ws.Name & "'." & vbCrLf & vbCrLf & _
"Should we continue with the procedure?" & vbCrLf & _
vbTab & "Yes: Continue with code" & vbCrLf & _
vbTab & "No: stop copying, save new workbook" & vbCrLf & _
vbTab & "Cancel: stop copying, erase new workbook", vbYesNoCancel, "Error")
Select Case lngAns
Case vbYes
'skip the data of the worksheet/table and continue
Case vbNo
'no more copying, save new workbook
Exit For
Case vbCancel
'close new workbook without saving
wbNew.Close False
GoTo end_here
End Select
End If
Case Else
End Select
Next ws
wsNew.Columns(4).NumberFormat = ThisWorkbook.Worksheets(1).ListObjects(1).ListColumns(4).DataBodyRange.NumberFormat 'time values
wsNew.UsedRange.Rows(1).Font.Bold = True 'header row bold
wsNew.UsedRange.EntireColumn.AutoFit 'adjust column width
wsNew.Name = "Data " & Format(Now, "yymmdd_hhmmss") 'name sheet
Application.Goto wsNew.Range("A1"), True
With ActiveWindow
.Split = False
.SplitColumn = 1
.SplitRow = 1
.FreezePanes = True
End With
'save in default folder with name of sheet as xlsx/macrofree
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51
end_here:
Set wsNew = Nothing
Set wbNew = Nothing
End Sub