将多个选项卡从文件夹复制到一个选项卡时出现excel VBA 1004错误答案

【问题标题】：excel VBA 1004 error when copying multiple tabs into one tab from a folder将多个选项卡从文件夹复制到一个选项卡时出现excel VBA 1004错误
【发布时间】：2018-02-21 08:18:19
【问题描述】：

我在尝试将工作簿页面合并到一个主文档时收到 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

当我运行它时，它可以正常工作，提示文件夹位置，询问它应该从哪些文件复制（通常是 *），然后从输入的工作表名称中复制。

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

谢谢！

【问题讨论】：

哪一行抛出异常？
不要Activate窗口，不要使用不合格的Sheets集合隐式引用活动工作簿。如果您打算仅使用 Worksheet 对象，请使用 Worksheets 集合而不是 Sheets 集合。请改用您的 wBk 工作簿对象引用。 wkb.Worksheets(wSht).Copy Before:=ThisWorkbook.Worksheets(1)。调用ThisWorkbook.Save 而不是依赖它在关闭wBk 后隐式重新激活。
另外，您的代码假定用户输入有效，并且不验证任何内容。也许从输入验证开始？
是网络驱动器上的文件。如果是这样，它们是否以相同的驱动器号映射到您的两台电脑上，例如“F：”。也许他的映射没有完成，他看到了路径 \\sa0036\blabla\foobar 而你看到的是相同的路径，如 "F:\foobar"
抛出错误的行是：Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) 对不起，我是新来的（今天注册）

标签： vba excel

【解决方案1】：

就像 Mat's Mug 所说，您应该真正验证您的输入。

您的同事是否在路径末尾添加了“\”？路径是否存在？

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

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

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

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

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

【讨论】：