Продолжайте вставлять данные в последовательные листы, когда предел строки текущего листа листов превышает 1 048 576

Question

Макрос, который я написал, копирует некоторые данные из нескольких файлов .dat на конкретный лист. Он работает нормально, если количество записей не превышает 1 048 576 строк в моей рабочей таблице (Excel 2016). Как изменить код, чтобы продолжить вставку данных из исходного файла в последующие таблицы при превышении максимальной строки в 1 048 576?

Сначала я попытался вставить данные из каждого исходного файла в отдельные листы в своей книге. Но это привело бы к созданию такого количества листов в рабочей тетради, которые я не хочу. Я хочу, чтобы мои данные были в минимальном количестве рабочих листов.

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

Ожидаемый результат - продолжить вставку данных в последовательные листы всякий раз, когда номер строки текущего рабочего листа превышает максимальный предел

Answer 1

Я не уверен, что это хорошая идея, чтобы Excel обрабатывал такой объем данных, и я не уверен, как вы хотите иметь дело с более чем одним листом, имеющим данные ...

1. Удалить On Error Resume Next.Он будет скрывать все ошибки, и вы никогда не узнаете, что в вашем коде возникла проблема.
2. Установите переменную wbA в начале и работайте с этим, а не с объектом Application.Worksheets.
3. Введите переменную счетчика листов.
4. Перед копированием диапазона проверьте, достаточно ли свободного места, иначе создайте следующий лист.
5. Выполните форматирование для всех листов,

Код может выглядеть следующим образом (не проверено, может содержать синтаксические ошибки)

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