Question

我已编写代码将位于不同工作簿中的不同工作表中的数据复制到新的主工作表，一切正常，除非工作簿数量从文件夹中的5增加，我得到此错误Run-time Error 1004然后导入停止。这是代码：

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")

    'change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("C:\Users\hnoorzai\Desktop\test\")
    Set filesObj = dirObj.Files

    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        'Change B3:H to the range your working on and also B in B65536 to any column required.
        bookList.Worksheets(1).Range("B3:H350" & Range("B65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate

        'Below only change "B" column name to your required column name
        Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

提前感谢您的帮助：）

Answer 1

我确信这是一个合格的问题，暗淡并相应地设置你的工作表和范围。

Sub Button1_Click()
    Dim bookList As Workbook, sh As Worksheet, rng As Range, rw As Long
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Dim wb As Workbook
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    'change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("C:\Users\Dave\Downloads\TextCSV\")
    Set filesObj = dirObj.Files
    Set wb = ThisWorkbook

    For Each everyObj In filesObj

        Set bookList = Workbooks.Open(everyObj)
        Set sh = bookList.Sheets(1)

        With sh
            rw = .Cells(.Rows.Count, "B").End(xlUp).Row
            Set rng = .Range("B3:H" & rw)
        End With

        'Change B3:H to the range your working on and also B in B65536 to any column required.
        rng.Copy

        With wb
            .Sheets(1).Cells(.Sheets(1).Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With

        bookList.Close

    Next

End Sub

Answer 2

我会避免激活任何工作簿并将值作为数组传输。

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

    'change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("C:\Users\hnoorzai\Desktop\test\")
    Set filesObj = dirObj.Files

    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
       .
        Set rSource = bookList.Worksheets(1).Range("B3:H350" & Range("B65536").End(xlUp).Row)

        Set Target = ThisWorkbook.Worksheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1, 0)

        Target.Resize(rSource.Rows.Count, rSource.Columns.Count).Value = rSource.Value

        bookList.Close
    Next
End Sub

复制超过5张数据后的运行时错误1004

2 个答案: