VB Runtime Error 1004

[NoahKR]

I have a workbook that is supposed to create a new worksheet for each project listed from A7 to A500 in the worksheet named "list," each new worksheet is supposed to have the same layout as the "template" worksheet. The full code is below.

It begins updating fine, but then I get a runtime error 1004: [FONT=Verdana, Arial, Helvetica]Method 'Copy' of Object'_Worksheet' failed
[/FONT]The error occurs here:

TemplateWks.Copy After:=Worksheets(Worksheets.Count)

I can work around this by saving, closing and then editing the range starting point, but there's got to be an easier solution to this.

thanks,
Noah

Sub CreateNameSheets()

Dim TemplateWks As Worksheet
Dim ListWks As Worksheet
Dim ListRng As Range
Dim myCell As Range

Set TemplateWks = Worksheets("template")
Set ListWks = Worksheets("list")
With ListWks
Set ListRng = .Range("a7", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each myCell In ListRng.Cells
TemplateWks.Copy After:=Worksheets(Worksheets.Count)
On Error Resume Next
ActiveSheet.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please fix: " & ActiveSheet.Name
Err.Clear
End If
On Error GoTo 0
Next myCell

End Sub

 

[Von Pookie]

...create a new worksheet for each project listed from A7 to A500 in the worksheet named "list,"... It begins updating fine, but then I get a runtime error 1004 ...I can work around this by saving, closing and then editing the range starting point, but there's got to be an easier solution to this.

I'm afraid not. Excel does that by design. If you copy a sheet multiple times without closing the workbook periodically, you will get that error.

You have two options: edit the code so that the workbook closes/reopens periodically while copying, or simply make a template workbook instead of copying the sheet.

http://support.microsoft.com/kb/210684

 

[NoahKR]

Thanks.

That Microsoft "solution" was the first place I looked, but when I added the fix to my code, it would think the same document was open multiple times and it would end up saving only one version which was always the first one that was saved -- meaning in the end it saved the document in the same place it would have gotten stuck if the save as code wasn't there. Did that make any sense?

Would you be able to help incorporate my code with a save, close, reopen code? I probably just didn't add the fix properly.

If this ends up being too complicated or it takes too long please don't worry about it, this report may just need to be updated manually.

thanks for your time,
Noah

 

[Von Pookie]

It'd be hard to put it into your code as-is, since the workbook running the code is the one you are copying the sheet(s) to. So when you close the workbook, the macro stops as well.

What you can do is copy the sheets to a separate workbook, so that you can close/reopen that one without affecting your point in the source range.

This is untested, but perhaps this would work or at least give you an idea:

Sub CreateNameSheets()
Dim wbNew As Workbook, wsNew As Worksheet
Dim wbNewPath As String
Dim TemplateWks As Worksheet, ListWks As Worksheet
Dim ListRng As Range, myCell As Range
Dim i As Integer

Set TemplateWks = Worksheets("template")
Set ListWks = Worksheets("list")
With ListWks
    Set ListRng = .Range("A7", .Cells(.Rows.Count, "A").End(xlUp))
End With

'create new workbook
Set wbNew = Workbooks.Add

'full location where to save new file (so we have this for reopening)
wbNewPath = "C:\newfile.xls"

For Each myCell In ListRng
    i = i + 1 'count for workbook close
    TemplateWks.Copy After:=wbNew.Worksheets(wbNew.Worksheets.Count)
    Set wsNew = wbNew.Worksheets(wbNew.Worksheets.Count)
    On Error Resume Next
    wsNew.Name = myCell.Value
    If Err.Number <> 0 Then
        MsgBox "Please fix: " & wsNew.Name
        Err.Clear
    End If
    On Error GoTo 0
    If i = 20 Then 'if count is up to 20
        wbNew.SaveAs (wbNewPath) 'save the new workbook
        wbNew.Close 'close the new workbook
        Set wbNew = Workbooks.Open(wbNewPath) 'reopen the new workbook
    Else
        i = i + 1 'continue copying
    End If
Next myCell

End Sub