将多个 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