将多个选项卡复制到文件夹中的一个选项卡时出现VBA 1004错误

当我尝试将工作簿页面合并到一个主文档中时，出现1004错误。 该代码在我的设备上正常工作，但是当我尝试在我的朋友设备上运行代码时，会抛出1004错误。 我相信他是在Excel 2013中，我在Excel 2016中。有没有办法将我的代码转换成可以在两个设备上使用的东西？

Sub CombineSheets() Dim sPath As String Dim sFname As String Dim wBk As Workbook Dim wSht As Variant Application.EnableEvents = False Application.ScreenUpdating = False sPath = InputBox("Enter a full path to workbooks") ChDir sPath sFname = InputBox("Enter a filename pattern") sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) wSht = InputBox("Enter a worksheet name to copy") Do Until sFname = "" Set wBk = Workbooks.Open(sFname) Windows(sFname).Activate Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) wBk.Close False sFname = Dir() Loop ActiveWorkbook.Save Application.EnableEvents = True Application.ScreenUpdating = True End Sub 

这运行正常，当我运行它，提示为文件夹的位置，询问它应该从哪个文件复制（通常*），然后特别复制input的工作表名称。

实际上，我需要的是能够从数百个excel文件中提取一个工作表并将它们合并成一个主文档的代码。 能够挑选哪些工作表就是奖金。

谢谢！

Answer 1

像马克杯子说，你应该真的validation你的投入。

你的同事在path的末尾添加了“\”吗？ path是否存在？

testing以确保工作表存在于您正在复制的文件中，如下所示：

 Function SheetExists(Name As String, Optional Workbook As Excel.Workbook = Nothing) As Boolean If Workbook Is Nothing Then Set Workbook = ThisWorkbook.Application.ActiveWorkbook On Error Resume Next If Workbook.Worksheets(Name).Name <> vbNullString Then End If If Err.Number = 0 Then SheetExists = True On Error GoTo 0 End Function 

这里是你的代码与指出的变化：

 Sub CombineSheets() Dim sPath As String Dim sFname As String Dim wBk As Workbook Dim sSht As String Application.EnableEvents = False Application.ScreenUpdating = False sPath = InputBox("Enter a full path to workbooks") 'Use the FolderPicker to verify the path With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then sPath = .SelectedItems(1) End With 'ChDir sPath sFname = InputBox("Enter a filename pattern") sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) sSht = InputBox("Enter a worksheet name to copy") Do Until sFname = "" Set wBk = Workbooks.Open(sFname) 'Windows(sFname).Activate If SheetExists(sSht, wBk) Then wBk.Sheets(sSht).Copy Before:=ThisWorkbook.Sheets(1) End If wBk.Close False sFname = Dir() Loop 'ActiveWorkbook.Save ThisWorkbook.Save Application.EnableEvents = True Application.ScreenUpdating = True End Sub 

更大的问题是，表是相同的大小？ 旧的.xls文件只有65536行，其中2007+ .xlsx文件最多可达1048576行。

您不能混合两个不同的工作表。 在这种情况下，您需要将所有单元格从一个表格复制到另一个表格。

 wBk.Sheets(sSht).Cells.Copy ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Sheets(1) ThisWorkbook.Sheets(1).Paste