Copying worksheet programmatically causes run-time error 1004 in Excel

[gquest]

Hey Everyone,

I have a procedure that creates a copies of a worksheet (template), renames and inserts them at a particular point in the workbook and then copies & pastes corresponding data from a database worksheet into this respective worksheets. The macro does this one at a time.

It works fine for the first 30-35 copies I use it, but if it goes above that number the macro fails and I get the following error:

Run-time error '1004'
Copy method of Worksheet class failed

After researching the issue, it appears to be a MS VBA bug where If you copy a sheet multiple times without closing the workbook periodically, you will get that error (source: hyperlink below).

Copying worksheet programmatically causes run-time error 1004 in Excel

I read MS' statement that, to get around this problem and it seems like there are only two options: (1) edit the code so that the workbook closes/reopens periodically while copying, or (2) make a template workbook instead of copying the sheet.

The first option would slow my macro down considerably, since the file takes a while to save and well I'm not really sure I understand the second option.

Is there an easier way to fix this issue or a better workaround then the two provided by Microsoft?

Any advice or help would be greatly appreciated!

Thank you in advance,

George

 

[Jonmo1]

I think you can get away with just saving the book periodically, not necessarily closing/reopening...

 

[gquest]

Here's my code if anyone is curious about my copy method. I'm also open to suggestion on cleaning up my coding.

Sub RunReport()
Dim wsheet As Worksheet
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="password"
For Each wsheet In Sheets
wsheet.Unprotect
Next wsheet

Sheets("Template").Visible = True

Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim A As Worksheet
Dim b As Worksheet
Dim icount As Long

Set A = Sheets("Input")
Set b = Sheets("Translation Table")
icount = A.Range("a4").Value

For Each Sheet In Sheets
Select Case Sheet.Name
Case "Input", "Template", "Translation Table", "Emails", "Sheet1"
'Do Nothing
Case Else
Sheet.Delete
End Select
Next Sheet

If icount > 1 Then

A.Range("a6").Copy
A.Range("a6").Resize(icount, 1).PasteSpecial xlPasteFormulas
A.Range("a6").Resize(icount, 1).Calculate

End If

A.Range("a6").Resize(icount, 29).Sort key1:=A.Range("a6")
A.Range("a5").Resize(icount + 1, 1).Copy
b.Range("i2").PasteSpecial xlPasteValues
b.Range("i2").Resize(icount + 1, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=b.Range("g2"), Unique:=True
b.Range("i2").Resize(icount + 1, 1).ClearContents
b.Range("h1").Calculate
b.Range("h3").Copy
b.Range("h3").Resize(b.Range("h1"), 1).PasteSpecial xlPasteFormulas
b.Range("h3").Resize(b.Range("h1"), 1).Calculate

Dim Lead As Range

For Each Lead In b.Range("g3").Resize(b.Range("h1").Value, 1)

Sheets("Template").Copy After:=Sheets(Sheets.Count)
Sheets("Template (2)").Name = Lead.Value

Sheets("Input").Select
Range("A:A").Find(What:=Lead.Value, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Resize(Lead.Offset(0, 1).Value, 28).Copy
Sheets(Lead.Value).Select
Sheets(Lead.Value).Range("A2").PasteSpecial xlPasteValues
Sheets(Lead.Value).Range("A2").PasteSpecial xlPasteFormats
Sheets(Lead.Value).Rows("1:1").AutoFilter
Next Lead

b.Range("h4").Resize(b.Range("h1") - 1, 1).ClearContents
b.Range("g3").Resize(b.Range("h1"), 1).ClearContents

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Sheets("Template").Visible = False
ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
Application.ScreenUpdating = True

End Sub

 

[gquest]

I think you can get away with just saving the book periodically, not necessarily closing/reopening...

jonmo1, I added code to save the workbook periodically, but still got the error message.

Also, I can't seem to get the save, close and re-open code that Microsoft provides to work, It saves and close the file, but doesn't seem to want to re-open or maybe it's working very slow.

I think the template option might be my best bet, but there's no code provided for it and I'm not really sure how to incorporate in a dynamic way. By dynamic, I mean move a copy of the template tab to a new workbook, save the workbook to the same location or desktop, use in the procedure and delete afterwards.

Work Around Option II From Microsoft:
To work around this problem, insert a new worksheet from a template instead of copying an existing worksheet. To do this, follow these steps, as appropriate for the version of Excel that you are running.

Microsoft Office Excel 2003 and earlier versions of Excel

1. Create a new workbook, and then delete all of the worksheets except for one.
2. Format the workbook, and then add any text, data, and charts that you must have in the template by default.
3. Click File, and then click Save As.
4. In the File name box, type the name that you want for the Excel template.
5. In the Save as type list, click Template (*.xlt), and then click Save.
6. To insert the template programmatically, use the following code:
   Sheets.Add Type:=path\filename

In this code, path\filename is a string that contains the full path and file name for your sheet template.

Any other ideas?

 

[shg]

If your code saves, closes, and reopens the worbook, it can't be running in that workbook.

 

[gquest]

If your code saves, closes, and reopens the worbook, it can't be running in that workbook.

shg4421, so I need to have it in another workbook, add-in or maybe a workbook in the XLSTART folder? Sorry, not really sure how to approach the issue now that you brought that up.

Isn't the code Microsoft provided below saving, closing and reopening while running in the same workbook (see below)?

Microsoft's Example Workaround Code:

'To resolve this problem, save and close the workbook periodically while the copy process is occurring, as in the following sample code:

Sub CopySheetTest()
    Dim iTemp As Integer
    Dim oBook As Workbook
    Dim iCounter As Integer
    
    ' Create a new blank workbook:
    iTemp = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set oBook = Application.Workbooks.Add
    Application.SheetsInNewWorkbook = iTemp
    
    ' Add a defined name to the workbook
    ' that RefersTo a range:
    oBook.Names.Add Name:="tempRange", _
        RefersTo:="=Sheet1!$A$1"
            
    ' Save the workbook:
    oBook.SaveAs "c:\test2.xls"
    
    ' Copy the sheet in a loop. Eventually,
    ' you get error 1004: Copy Method of
    ' Worksheet class failed.
    For iCounter = 1 To 275
        oBook.Worksheets(1).Copy After:=oBook.Worksheets(1)
        'Uncomment this code for the workaround:
        'Save, close, and reopen after every 100 iterations:
        If iCounter Mod 100 = 0 Then
            oBook.Close SaveChanges:=True
            Set oBook = Nothing
            Set oBook = Application.Workbooks.Open("c:\test2.xls")
        End If
    Next
End Sub

I tried taking this code and applying it to mine, but as previously mentioned it's not working. Below is my macro with the Save, Close, Re-Open Procedure added. I think the issue might have something to do with the iCounter piece. Do I need to set that?

My Code + Microsoft's Example Workaround Code:

Sub RunReport()
    Dim wsheet As Worksheet
    Dim pbook As Workbook
    Dim A As Worksheet
    Dim b As Worksheet
    Dim Lead As Range
    Dim icount As Long
    Dim iCounter As Integer
        Set A = Sheets("Input")
        Set b = Sheets("Translation Table")
        icount = A.Range("a4").Value
        Set pbook = ActiveWorkbook

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.CalculateBeforeSave = False
    Application.DisplayAlerts = False
    ActiveWorkbook.Unprotect Password:="password"

    For Each wsheet In Sheets
        wsheet.Unprotect
    Next wsheet

    Sheets("Template").Visible = True

    For Each Sheet In Sheets
        Select Case Sheet.Name
        Case "Input", "Template", "Translation Table", "Emails", "Sheet1"
            'Do Nothing
        Case Else
            Sheet.Delete
        End Select
    Next Sheet

    If icount > 1 Then
        A.Range("a6").Copy
        A.Range("a6").Resize(icount, 1).PasteSpecial xlPasteFormulas
        A.Range("a6").Resize(icount, 1).Calculate
    End If

    A.Range("a6").Resize(icount, 29).Sort key1:=A.Range("a6")
    A.Range("a5").Resize(icount + 1, 1).Copy
    b.Range("i2").PasteSpecial xlPasteValues
    b.Range("i2").Resize(icount + 1, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=b.Range("g2"), Unique:=True
    b.Range("i2").Resize(icount + 1, 1).ClearContents
    b.Range("h1").Calculate
    b.Range("h3").Copy
    b.Range("h3").Resize(b.Range("h1"), 1).PasteSpecial xlPasteFormulas
    b.Range("h3").Resize(b.Range("h1"), 1).Calculate

    For Each Lead In b.Range("g3").Resize(b.Range("h1").Value, 1)
        If iCounter Mod 100 = 0 Then
            pbook.Close SaveChanges:=True
            Set pbook = Nothing
            Set pbook = Application.Workbooks.Open("C:\Documents and Settings\gsmith\My Documents\2011\Template.xls")
            
            pbook.Sheets("Template").Copy After:=pbook.Sheets(Sheets.Count)
            pbook.Sheets("Template (2)").Name = Lead.Value
                Sheets("Input").Select
                Range("A:A").Find(What:=Lead.Value, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Resize(Lead.Offset(0, 1).Value, 28).Copy
                Sheets(Lead.Value).Select
                Sheets(Lead.Value).Range("A2").PasteSpecial xlPasteValues
                Sheets(Lead.Value).Range("A2").PasteSpecial xlPasteFormats
                Sheets(Lead.Value).Rows("1:1").AutoFilter
        End If
    Next Lead

    b.Range("h4").Resize(b.Range("h1") - 1, 1).ClearContents
    b.Range("g3").Resize(b.Range("h1"), 1).ClearContents

    Sheets("Template").Visible = False

    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Any suggestions or ideas on how to fix or workaround the issue I am having? I've searched around on the web and on this board and wasn't able to find any real solutions.

Thanks again for the help!

 

[shg]

If you have code running in a workbook, and that code closes the workbook it's in, that code is done running, right?

Yes, an add-in would be a good place to put it. It would typically go (in XP) in

C:\Documents and Settings\username\Application Data\Microsoft\AddIns

If you want to put it someplace else (like where you keep other add-ins), put a link in that directory to your directory.