У меня ошибка времени выполнения 1004 при объединении нескольких экземпляров в один

Question

Я получил этот массаж ошибок при объединении содержимого нескольких файлов Excel в один.Я знаю, что это происходит потому, что осталось не так много места.Может кто-нибудь помочь мне, как включить правило, например, если места недостаточно, затем откройте новый лист и вставьте туда оставшийся контент?

Вот оно:

Sub simpleXlsMerger()
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")


    Set dirObj = mergeObj.Getfolder("C:\Users\JudakV\Desktop\xxxmacro\")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        Range("A2:IV" & Range("1000000").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate

        Range("A1000000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

Существуетмой отчет, в котором требуется скопировать и вставить содержимое нескольких (около 20) файлов Excel в один файл, и если в нем содержится более 1 млн строк (обычно больше), откройте новый лист и скопируйте оставшуюся часть.Я не очень хорош в макросах, но это может сэкономить мне много времени, если это сработает.Но меня беспокоит ограничение по количеству страниц и открытие новой части рабочего листа ...

Answer 1

Этот код скопирует данные на новые листы.Я не тестировал большие объемы данных, но должен работать.

Public Sub XLMerger()

    Dim oFSO As Object
    Dim oDir As Object
    Dim oFiles As Object
    Dim oFle As Object
    Dim wrkBk As Workbook
    Dim tgtLastCell As Range 'Target last cell.
    Dim srcLastCell As Range 'Source last cell.
    Dim lRequiredRows As Long
    Dim lAvailableRows As Long
    Dim tgtSheet As Worksheet

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oDir = oFSO.GetFolder(""C:\Users\JudakV\Desktop\xxxmacro\"")
    Set oFiles = oDir.Files

    'Will be pasting data into this sheet.
    Set tgtSheet = ThisWorkbook.Worksheets("Sheet1")

    For Each oFle In oFiles
        If InStr(oFle.Type, "Excel") > 0 Then
            Set wrkBk = Workbooks.Open(Filename:=oFle, ReadOnly:=True)

            'Set reference to last cell on Target sheet.
            With tgtSheet
                'If there is data on the very last row an
                'incorrect reference will be returned.
                If .Cells(.Rows.Count, 1) <> "" Then
                    Set tgtLastCell = .Cells(.Rows.Count, 1)
                Else
                    Set tgtLastCell = .Cells(.Rows.Count, 1).End(xlUp)
                End If
            End With

            With wrkBk.Worksheets("Sheet1")
                'Set reference to last cell on Source sheet.
                Set srcLastCell = .Cells(.Rows.Count, 1).End(xlUp)

                'Will it fit?
                lRequiredRows = srcLastCell.Row - 1
                lAvailableRows = ThisWorkbook.Worksheets("Sheet1").Rows.Count - tgtLastCell.Row

                If lRequiredRows <= lAvailableRows Then
                    'Straight Copy/Paste as it all fits.
                    .Range(.Cells(2, 1), .Cells(srcLastCell.Row, 256)).Copy
                    tgtLastCell.Offset(1).PasteSpecial xlPasteValues
                Else
                    'Copy what we can onto old sheet providing there's at least 1 blank row.
                    If lAvailableRows > 0 Then
                        .Range(.Cells(2, 1), .Cells(lAvailableRows + 1, 256)).Copy
                        tgtLastCell.Offset(1).PasteSpecial xlPasteValues
                    End If

                    'Create a new sheet, copy headings over and paste remaining data.
                    'The IIF command ensures lAvailable rows isn't looking at row 0.
                    Set tgtSheet = ThisWorkbook.Worksheets.Add
                    ThisWorkbook.Worksheets("Sheet1").Rows(1).Copy Destination:=tgtSheet.Range("A1")
                    .Range(.Cells(lAvailableRows + IIf(lAvailableRows = 0, 2, 0), 1), .Cells(srcLastCell.Row, 256)).Copy
                    tgtSheet.Range("A2").PasteSpecial xlPasteValues

                End If

            End With
            Application.DisplayAlerts = False
            wrkBk.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
    Next oFle

End Sub