Copying Worksheets in VBA Copy Error

问题:

Hi I'm having a problem copying worksheets from one workbook to another in VB. The code I have works fine with brand new workbooks, but after awhile it breaks and gives me this error: "Method 'Copy' of object '_Worksheet' failed. A lot of people suggested saving the workbook and reopening it when you are copying. I tried that and it still didn't work. I also checked if maybe the name is becoming really long. I set the name of the worksheet to the counter before copying it, and I still got the bug. I am really confused, and hope someone may have figured out a solution to this. Also both workbooks only have 3 worksheets in them.

'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

Edit: What I meant with "this workbook breaks after awhile" is that I can run this code on it multiple times (maybe around 30 times). Eventually this error comes up "Method 'Copy' of object '_Worksheet' failed" even if I delete the worksheets in the dest_wb. It points at the Copy line.

回答1:

I've had a similar problem copy worksheets from a 'template' file. I think it is a memory problem which kicks in after a certain number of copy and pastes (depending on your system).

Depending on what your worksheets contain, there are a few workarounds. I haven't needed to loop through many workbooks, but I've found the following function effectively does the same thing without any issues.

Just a few things to note though, you're probably not helping by creating two new instances of Excel each time you copy the worksheets from one workbook to another. Why can't you use the instance of Excel just use at least one instance of 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

回答2:

Yes, I have exactly the same problem in some code that I use, though it's never been pressing enough for me to do what is (apparently) necessary for me to fix it.

The issue is described in this knowledgebase article. The article suggests that:

To resolve this problem, save and close the workbook periodically while the copy process is occurring

I note that you said that you are "saving and reopening the workbook when copying" but I assume that you're doing that before you run the code since I don't see any indication of it being done during the loop. One way of doing it inside the loop itself would be:

Implement error handling by having an

On Error Goto

line early in the procedure; then

Putting an

Exit Function
ErrorHandler:

block at the bottom. Inside the error handler itself you would need to check whether the Err.Number is 1004. If it is, close both source and destination workbooks, then re-open both, and resume at the line that the error occurred on. It would be a good idea to keep track of how many calls to the error handler are made and just give up after a certain number to ensure that you don't end up in an infinite loop.

This is basically the idea that I had for resolving my issue but I've never had the time / pressing need to implement it. I'd have tested it out before posting this but the files are at the office and I don't currently have access to them.

I'd be interested to see how you go if you decide to go down that path.

The other option is the one suggested in the KB article which is to close and reopen the book after n iterations. The issue with that is that it suggests 100 iterations whereas mine fails after 32 or 33. (It seems to depend on the size of the sheet, amongst other things.) Also there are occasions when mine fails after 10 (with exactly the same sheets) and the only way to fix that is to close and re-open Excel. (Obviously not much of an option for VBA-based code.)