VBA for copying all data from 8 sheets in a single workbook to a new sheet in new workbook

[sdhasan]

Hi Guys,

Need help in creating a macro which will be saved in the workbook containing 8 sheets with the same table. The macro will copy all the data in the table in those eight sheets and will paste it in a new sheet in a new workbook. The fourth row in each sheet is the header of the table which needs to be copied only once.

 

[Flaiban]

Create a button in your new workbook , copy and paste this code below :

Option Explicit

Const Ttrows = 1048576

Private sub Btexecut_click ' button name

Dim W as Worksheet
Dim  Sht as Worksheet
Dim Wnew as workbook
Dim ArcToOpen as Variant
Dim A as Integer
Dim ArchiveName as String

ArcToOpen = application.getopenfilename("Import Archive (*.xls*), *.xls*", Title:="Choose Archives", Multiselect:=True)

If not IsArray (ArcToOpen) Then
      
    If ArcToOpen = "" or ArcToOpen = false then
           msgbox "Annulled Process. File not Selected !"
           Exit Sub
    End If

End If

Application.ScreenUpDating = false

Set W = sheets("Sheet1")

W.Select
W.UsedRange.EntireColumn.Delete

For A = lbound(ArcToOpen) to ubound(ArcToOpen)

     ArchiveName = ArcToOpen(A)
     Application.Workbooks.Open ArcToOpen(A)
     
     Set Wnew = ActiveWorkbook

     for each Sht in Wnew.sheets

           Sht.select
           Sht.range("A4").currentregion.select

           selection.copy destination:=w.cells(Ttrows,1).end(xlup).offset(1,0)

     Next sht

     Application.DisplayAlerts = false

         wnew.close savechanges:=false

     Application.DisplayAlerts = true

     w.cells(Ttrows,1).end(xlup).offset(1,0).select

Next

Application.ScreenUpDating = true

msgbox "Process completed successfully."

end sub

 

[HaHoBe]

Hi sdhasan,

what about

Sub MrE1612712()
'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/
'based on
'https://www.mrexcel.com/board/threads/need-macro-to-copy-data-from-multiple-sheets-into-a-new-workbook.1219037
Dim ws              As Worksheet
Dim wbNew           As Workbook
Dim wsNew           As Worksheet
Dim lngStart        As Long
Dim lngCounter      As Long

Const clngRowsBetweenTables     As Long = 2

Set wbNew = Workbooks.Add(1)
Set wsNew = wbNew.Sheets(1)
lngStart = 1

For Each ws In ThisWorkbook.Worksheets
  lngCounter = lngCounter + 1
  If lngCounter = 1 Then
    ws.ListObjects(1).Range.Copy
  Else
    lngStart = wsNew.Range("A" & Rows.Count).End(xlUp).Row + 1 + clngRowsBetweenTables
    ws.ListObjects(1).DataBodyRange.Copy
  End If
  wsNew.Range("A" & lngStart).PasteSpecial xlPasteValues
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
'save in default folder with name of sheet as xlsx/macrofree
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

 

[HaHoBe]

Hi sdhasan,

options to choose if one or all headers will be copied and if any blank rows should be inserted:

Sub MrE1612714()
'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
Dim ws                          As Worksheet
Dim wbNew                       As Workbook
Dim wsNew                       As Worksheet
Dim lngStart                    As Long
Dim lngCounter                  As Long
Dim lngOffset                   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
  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
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
'save in default folder with name of sheet as xlsx/macrofree
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

 

[sdhasan]

Hi sdhasan,

options to choose if one or all headers will be copied and if any blank rows should be inserted:

Sub MrE1612714()
'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
Dim ws                          As Worksheet
Dim wbNew                       As Workbook
Dim wsNew                       As Worksheet
Dim lngStart                    As Long
Dim lngCounter                  As Long
Dim lngOffset                   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
  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
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
'save in default folder with name of sheet as xlsx/macrofree
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

Hello Holger,

I'm getting the following error while running the code:

Also kindly note that there are 12 sheets in the workbook and only the first 8 needs to be copied.

 

[sdhasan]

Create a button in your new workbook , copy and paste this code below :

Option Explicit

Const Ttrows = 1048576

Private sub Btexecut_click ' button name

Dim W as Worksheet
Dim  Sht as Worksheet
Dim Wnew as workbook
Dim ArcToOpen as Variant
Dim A as Integer
Dim ArchiveName as String

ArcToOpen = application.getopenfilename("Import Archive (*.xls*), *.xls*", Title:="Choose Archives", Multiselect:=True)

If not IsArray (ArcToOpen) Then
     
    If ArcToOpen = "" or ArcToOpen = false then
           msgbox "Annulled Process. File not Selected !"
           Exit Sub
    End If

End If

Application.ScreenUpDating = false

Set W = sheets("Sheet1")

W.Select
W.UsedRange.EntireColumn.Delete

For A = lbound(ArcToOpen) to ubound(ArcToOpen)

     ArchiveName = ArcToOpen(A)
     Application.Workbooks.Open ArcToOpen(A)
    
     Set Wnew = ActiveWorkbook

     for each Sht in Wnew.sheets

           Sht.select
           Sht.range("A4").currentregion.select

           selection.copy destination:=w.cells(Ttrows,1).end(xlup).offset(1,0)

     Next sht

     Application.DisplayAlerts = false

         wnew.close savechanges:=false

     Application.DisplayAlerts = true

     w.cells(Ttrows,1).end(xlup).offset(1,0).select

Next

Application.ScreenUpDating = true

msgbox "Process completed successfully."

end sub

Hello,

The code works great, however I dont need to copy data from 8 workbooks, rather I want to copy 8 sheets from one workbook (the workbook has 12 sheets in total, I only need to copy the first eight)

 

[HaHoBe]

Hi sdhasan,

the run time error will be triggered if not table is found on a worksheet while processing all sheets in the workbook - I misunderstood

...in the workbook containing 8 sheets with the same table.

as to be there only 8 worksheets.

I can think of a couple of ways to work around this: working with the Index (position of worksheets in workbook - not very reliable to my opinion as sheets may easily be dragged to a different position), checking for the sheetname to work on (might run into problems if the name could be changed by user), check for the CodeName of a sheet (similar to tab name only that ws.Name should be replaced with ws.CodeName and the name of the worksheet from the Project Explorer should be used instead of the tab sheet name), or check if a ListObject is on a worksheet.

Code checking worksheet tab names:

Sub MrE1612714_V2()
'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
Dim ws                          As Worksheet
Dim wbNew                       As Workbook
Dim wsNew                       As Worksheet
Dim lngStart                    As Long
Dim lngCounter                  As Long
Dim lngOffset                   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.Name
    'change the names of the worksheet tabs to suit
    Case "Revenue Share Scheme", "Karwa White (Temporary)", "WS2Copy1", "WS2Copy2", "WS2Cop3", _
          "WS2Cop4", "WS2Cop5", "WS2Cop6"
      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
    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

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Code checking if there is a ListObject on the worksheet:

Sub MrE1612714_V3()
'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
Dim ws                          As Worksheet
Dim wbNew                       As Workbook
Dim wsNew                       As Worksheet
Dim lngStart                    As Long
Dim lngCounter                  As Long
Dim lngOffset                   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
  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
  End If
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
'save in default folder with name of sheet as xlsx/macrofree
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

 

[HaHoBe]

Hi sdhasan,

a combined version to check for the codename of the sheets to copy as well as that there is a ListObject to copy and the option of user to decide on how to continue (be sure to adjust the codenames to suit). These can only be found in the VBE either in the Project Explorer (press CTRL+R if not visibleor use command in View) to the left of the worksheet tab name in brackets or in Properties (F4 to make visible or use command in View) under (Name):

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

Ciao,
Holger

 

[sdhasan]

Hi sdhasan,

a combined version to check for the codename of the sheets to copy as well as that there is a ListObject to copy and the option of user to decide on how to continue (be sure to adjust the codenames to suit). These can only be found in the VBE either in the Project Explorer (press CTRL+R if not visibleor use command in View) to the left of the worksheet tab name in brackets or in Properties (F4 to make visible or use command in View) under (Name):

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

Ciao,
Holger

Hi Holger,

Appreciate your constant help, the above code is showing error. Let me share with you the same file to run and check your code.
The data that I want copied is in the following sheets:
Airport Taxi
Airport Taxi (Temp Driver)
Revenue Share Scheme
Karwa White
Karwa White (Temporary)
Annual Leave
Resign & Termination
Incident
The data that needs to be copied starts from A4 till the end. The header of the table needs to be copied once only and blank rows needs to be removed.
Here's the link to the sample file for you to check your code: Loading Google Sheets

 

[HaHoBe]

Hi sdhasan,

thanks for sharing the workbook.

...workbook containing 8 sheets with the same table

A table in Excel is a ListObject but there are none in the sample provided. So my code can't work as it expects ListObjects in each worksheet.

Maybe next time you better convert all the formulas to values because these slow down the performance.

The data that needs to be copied starts from A4 till the end.

Really? I collected the data from all relevant sheets and Row 4

Name Worksheet	Header Row
Airport Taxi	4	SN	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Car #	Type	Vehicle status	Day off	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Location	Partner	Date	Effective date	Changes	Reason Of Change	Reminders
Airport Taxi (Temp. driver)	4	SN	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Car #	Type	Vehicle status	Day off	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Location	Partner	Date of On road	Changes	Reason Of Change	Reminders
Revenue Share Scheme	4	S/N	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Car #	Type	Vehicle status	Day off	60:40 Effective Date	Change Date	Effective Date	Reminders			Corolla	0
Karwa White	4	S/N	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Car #	Type	Vehicle status	Day off	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Partner	Effective Date
Karwa White (Temporary)	4	S/N	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Car #	Type	Vehicle status	Day off	Emp.#	Name	Category	Shift/ Time Code	Mursaal ID	Mobile	Rel	Nationality	Partner	Effective Date
Annual Leave	4	2	2016538	Abdul Aziz Mharami Faki	Airport Taxi	DD 14:00	123052	30104701	28-Aug-22	6-Sep-22	10	#WERT!	Leave Overdue		37
Resign & Termination	4
Incident	4
Annual Leave	2
Resign & Termination	1
Incident	1

I think it's your turn to tell us if you need all the data concerning different aspects directly beneath a header which will not reflect the data displayed. Information on the mentioned sheets is not having the same layout so a lot of programming would be necessary to align data in a way that I would call usable. This includes the information on where to add additional information as columns.

Ciao,
Holger