excel - 将几个优点合并到一个时出现运行时错误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文件的内容复制并粘贴到一个文件中，如果它具有超过1M行(通常超过该行)，则打开一个新工作表并复制其余在那里。
我不擅长宏，但是如果可以的话，它可以为我节省很多时间。但是我为页面限制而烦恼，并打开了一个新的工作表部分的东西...

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