在 VBA 复制错误中复制工作表

Question

您好，我在 VB 中将工作表从一个工作簿复制到另一个工作簿时遇到问题。我的代码在全新的工作簿上运行良好，但过了一段时间它会中断并给我这个错误：“对象'_Worksheet'的方法'复制'失败。很多人建议保存工作簿并在复制时重新打开它。我试过了，它仍然没有用。我还检查了名称是否变得很长。我在复制之前将工作表的名称设置为计数器，但我仍然遇到错误。我真的很困惑，并且希望有人可能已经找到解决方案。而且两个工作簿中只有 3 个工作表。

'Copies all the worksheets from one workbook to another workbook
'source_name is the Workbook's FullName
'dest_name is the Workbook's FullName
Function copyWorkbookToWorkbook(source_name As String, dest_name As String) As Boolean
    Dim dest_wb As Workbook
    Dim source_wb As Workbook
    Dim dest_app As New Excel.Application
    Dim source_app As New Excel.Application
    Dim source_ws As Worksheets
    Dim counter As Integer
    Dim num_ws As Integer
    Dim new_source As Boolean
    Dim new_dest As Boolean
    Dim ws As Worksheet
    Dim regex As String

    Application.ScreenUpdating = False

    If source_name = "" Or dest_name = "" Then
        MsgBox "Source and Target must both be selected!", vbCritical
        copyWorkbookToWorkbook = False
    ElseIf GetAttr(dest_name) = vbReadOnly Then
        MsgBox "The target file is readonly and cannot be modified", vbCritical
        copyWorkbookToWorkbook = False
    Else
        regex = "[^\\]*\.[^\\]*$"   'Gets only the filename
        copyWorkbookToWorkbook = True

        If (isWorkbookOpen(source_name)) Then
            Set source_wb = Workbooks(regExp(source_name, regex, False, True)(0).Value)
        Else
            Set source_wb = source_app.Workbooks.Open(source_name)
            new_source = True
        End If

        If (isWorkbookOpen(dest_name)) Then
            Set dest_wb = Workbooks(regExp(dest_name, regex, False, True)(0).Value)
        Else
            Set dest_wb = dest_app.Workbooks.Open(dest_name)
            new_dest = True
        End If

        'Clean the workbooks before copying the data
        'Call cleanWorkbook(source_wb)
        'Call cleanWorkbook(dest_wb)

        'Copy each worksheet from source to target

        counter = 0
        source_wb.Activate
        For Each ws In source_wb.Worksheets
            MsgBox dest_wb.Worksheets.Count
            ws.Copy After:=dest_wb.Worksheets(dest_wb.Worksheets.Count)
            counter = counter + 1
        Next ws

        'Save and close any newly opened files
        If (new_dest) Then
            dest_wb.Application.DisplayAlerts = False
            dest_wb.SaveAs Filename:=dest_name, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
            dest_wb.Application.CutCopyMode = False
            dest_wb.Close
        End If
        If (new_source) Then
            source_wb.Application.DisplayAlerts = False
            source_wb.SaveAs Filename:=source_name, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
            source_wb.Close
        End If

        MsgBox counter & " worksheets have been cleaned and copied.", vbInformation + vbOKOnly

    End If

    'Cleanup
    Set dest_wb = Nothing
    Set source_wb = Nothing
    Set dest_app = Nothing
    Set source_app = Nothing
    Set source_ws = Nothing
    Set ws = Nothing
End Function

Function regExp(str As String, pattern As String, ignore_case As Boolean, glo As Boolean) As MatchCollection
    Dim regex As New VBScript_RegExp_55.regExp
    Dim matches As MatchCollection

    regex.pattern = pattern
    regex.IgnoreCase = ignore_case
    regex.Global = glo

    Set regExp = regex.Execute(str)
End Function

编辑：我所说的“这个工作簿会在一段时间后中断”的意思是我可以在上面多次运行这段代码（可能大约 30 次）。即使我删除了dest_wb中的工作表，最终也会出现此错误“对象'_Worksheet'的方法'复制'失败”。它指向复制行。

Answer 1

我在从“模板”文件中复制工作表时遇到了类似的问题。我认为这是一个内存问题，在一定数量的复制和粘贴后会出现（取决于您的系统）。

根据您的工作表包含的内容，有一些解决方法。我不需要遍历许多工作簿，但我发现以下函数有效地完成了同样的事情而没有任何问题。

尽管有几点需要注意，但每次将工作表从一个工作簿复制到另一个工作簿时，创建两个新的 Excel 实例可能无济于事。为什么不能使用 Excel 的实例，至少使用一个 Excel 实例。

Sub CopyWorksheet(wsSource As Worksheet, sName As String, wsLocation As Worksheet, sLocation As String)
    'Instead of straight copying we just add a temp worksheet and copy the cells.
    Dim wsTemp As Worksheet

    'The sLocation could be a boolean for before/after. whatever.
    If sLocation = "After" Then
        Set wsTemp = wsLocation.Parent.Worksheets.Add(, wsLocation)
    ElseIf sLocation = "Before" Then
        Set wsTemp = wsLocation.Parent.Worksheets.Add(wsLocation)
    End If

    'After the new worksheet is created
    With wsTemp
        .Name = sName                           'Name it
        .Activate                               'Bring it to foreground for pasting
        wsSource.Cells.Copy                     'Copy all the cells in the original
        .Paste                                  'Paste all the cells
        .Cells(1, 1).Select                     'Select the first cell so the whole sheet isn't selected
    End With
    Application.CutCopyMode = False
End Sub

Answer 2

是的，我在使用的某些代码中遇到了完全相同的问题，尽管它从来没有足够的压力让我去做（显然）我必须做的事情来修复它。

this 知识库文章中描述了该问题。文章建议：

要解决此问题，请定期保存并关闭工作簿 在复制过程中

我注意到您说您“在复制时正在保存并重新打开工作簿”，但我假设您在运行代码之前已经这样做了，因为我没有看到任何迹象表明它在循环期间已完成。在循环本身内部执行此操作的一种方法是：

通过

实现错误处理

On Error Goto

在程序的早期行；那么

放一个

Exit Function
ErrorHandler:

块在底部。在错误处理程序本身内部，您需要检查 Err.Number 是否为 1004。如果是，请关闭源工作簿和目标工作簿，然后重新打开它们，并在发生错误的行处继续。跟踪对错误处理程序进行了多少次调用并在达到一定数量后放弃以确保您不会陷入无限循环是一个好主意。

这基本上是我解决问题的想法，但我从来没有时间/迫切需要实施它。我会在发布之前对其进行测试，但文件在办公室，我目前无法访问它们。

如果你决定走这条路，我很想看看你会怎么走。

另一个选项是知识库文章中建议的选项，即在 n 次迭代后关闭并重新打开这本书。问题在于它建议 100 次迭代，而我的迭代在 32 或 33 之后失败。（这似乎取决于工作表的大小，除其他外。）还有一些情况下，我的迭代在 10 次之后失败（使用完全相同的工作表)，解决此问题的唯一方法是关闭并重新打开 Excel。 （对于基于 VBA 的代码，显然没有太多选择。）