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

我已经编写代码将数据从位于不同的工作簿的不同工作表复制到新的主工作表，一切工作正常，除非工作簿的数量从文件夹中的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