Continue pasting data in successive worksheets when the current workhseet's row limit exceeds 1,048,576

Question

The macro I wrote copies some data from several .dat files to a specific worksheet. It works fine as long as the number of records don't exceed the maximum 1,048,576 rows in my worksheet(excel 2016). How to modify the code to continue pasting data from the source file to the successive worksheets when the max row of 1,048,576 is exceeded?

I first tried to paste data from each source file in individual worksheets in my workbook. But that would create so many sheets in the workbook which I don't want. I want my data to be in minimum number of worksheets as possible.

Sub KLT()

Dim StartTime As Double
Dim MinutesElapsed As String
Dim wbA As Workbook, wbB As Workbook
Dim button_click As VbMsgBoxResult
Dim myPath As String, myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim count As Integer
Dim LIST As Integer
Dim xWs As Worksheet
Dim sh As Worksheet
Dim xcount As Integer

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False

On Error Resume Next
'Remember time when macro starts
  StartTime = Timer
'Deleting the "Start" sheet from previous macro run
For Each xWs In Application.Worksheets
        If xWs.Name = "Start" Then
            xWs.Delete
        End If
Next

'Adding a new Sheet called "Start"
Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = "Start"
Set wbA = ThisWorkbook
Set sh = wbA.Sheets("Start")

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False

        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
 'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.DAT*" 'my data is in .dat files

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension) 'Storing the actual raw file name

'Loop through each Excel file in folder
Execute:
Do While myFile <> ""
                'Set variable equal to opened workbook
                Set wbB = Workbooks.Open(Filename:=myPath & myFile)

                'The source file range might be a continuation of a previous file, so ensuring the correct range is identified always
                If wbB.ActiveSheet.Range("A1").Value = "Continuation of previous file." Then Range("A1").EntireRow.Delete

                'Filtering data set and choosing data below headers
                With wbB.ActiveSheet
                    .AutoFilterMode = False
                    With Range("A1", Range("A" & Rows.count).End(xlUp)) 'I am only interested in the data below the header
                        .AutoFilter 1, "*Cycle*"
                        On Error Resume Next
                        .Offset(1).SpecialCells(12).EntireRow.Delete
                        .AutoFilter 1, "*Profile*"
                        On Error Resume Next
                        .Offset(1).SpecialCells(12).EntireRow.Delete
                    End With
                    .AutoFilterMode = False
                End With

                'Choosing the desired range to be copied
                Set Rng = Union _
                (Range("A2", Range("A2").End(xlDown)), _
                 Range("D2", Range("D2").End(xlDown)), _
                 Range("E2", Range("E2").End(xlDown)), _
                 Range("AX2", Range("AX2").End(xlDown)))

                'Rng.Select

                '''Copying relevant information from the source file & pasting in the Start worksheet'''
                lr = sh.Range("A" & Rows.count).End(xlUp).Row + 1
                    Rng.Copy sh.Range("A" & lr)

                'Keeping the count of how many files have been worked on
                If InStr(1, ActiveSheet.Name, "LifeCyc") > 0 Then xcount = xcount + 1
                'Debug.Print xcount
                ''''''''***********''''''''

                'Close Workbook
                wbB.Close 'SaveChanges:=True

                'Ensure Workbook has closed before moving on to next line of code
                DoEvents

                'Get next file name
                myFile = Dir

Loop

'Creating the headers in my report sheet
With sh
.Range("A1").Value = "Date"
.Range("B1").Value = "CumSec"
.Range("C1").Value = "LifeCycleNo"
.Range("D1").Value = "dT"
End With

'Formatting the headers
With sh.Range("A1:D1")
.Interior.Color = rgbBlue
.LineStyle = xlContinuous
.Borders.Color = rgbBlack
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.Color = rgbWhite
End With

'Formatting the actual dataset
With sh.Range("A2:D2", Range("A2:D2").End(xlDown))
.LineStyle = xlContinuous
.Borders.Color = rgbBlack
End With

Columns("A:D").AutoFit

'Determine how long the code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

'Displaying a message on the screen after completion of the task
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes " & "Total Raw Files Processed: " & CStr(xcount), vbInformation

'Reset Macro Optimization Settings
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = False
    Application.AutomationSecurity = lSecurity

End Sub

Expected outcome is to continue pasting data in successive sheets whenever the current worksheet's row number exceeds the max limit

Answer 1

I am not convinced that it is a good idea to let Excel handle such an amount of data, and I am not sure how you want to deal with more than one sheet having data...

1. Remove On Error Resume Next. It will hide all errors and you will never recognize that your code had a problem.
2. Set your wbA-variable at the beginning and work with that, not with then Application.Worksheets object.
3. Introduce a sheet-counter variable.
4. Before copying the Range, check if you have enough space left, else create the next sheet.
5. Do the formatting for all sheets.

Code could look like this (untested, may contain syntax errors)

const SHEETNAME = "Start"

Set wbA = ThisWorkbook
For Each xWs In wbA.Worksheets
    If xWs.Name like SHEETNAME & "*" Then
        xWs.Delete
    End If
Next xWs

dim sheetCount as Long
sheetCount = 1
set sh = wbA.Worksheets.Add(After:=wbA.Worksheets(wbA.Worksheets.count))
sh.Name = SHEETNAME & sheetCount
(...)

    lr = sh.Range("A" & Rows.count).End(xlUp).row + 1
    If lr + rng.rows.count > sh.Rows.count then
        ' Not enough space left, add new sheet.
        sheetCount = sheetCount + 1
        set sh = wbA.Worksheets.Add(After:=sh)
        sh.Name = SHEETNAME & sheetCount
        lr = 1
    End if
    rng.Copy sh.Range("A" & lr)
(...)

' Format all data sheets.
For Each xWs In wbA.Worksheets
    with xWs
        If .Name like SHEETNAME & "*" Then
            .Range("A1").Value = "Date"
            (...)
            ' Create a table
            lr = .Range("A" & Rows.count).End(xlUp).row
            .ListObjects.Add(xlSrcRange, .Range("$A$1:$D$" & lr), , xlYes).Name = "Table_" & .Name

        End If
    End With
Next xWs