Workbook creation problem

[trebor3900]

I have a clothing Database that orders and issues clothing items to members of staff.

The program also keeps an account of clothing not issued and therefore still in stock.

In order to have a written record of this, i have been able to write a routine that creates an Excel Workbook that puts each item into its own worksheet so that i can have a record of individual items.

This routine works but when i run it a second time i get the error message..Runtime error 1004..
Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic...

Code for the click event is:

Private Sub imgStockVoucher_Click()
Dim objXLApp As Object
Dim objXLWb As Excel.Workbook
Dim objXLWs As Excel.Worksheet
Dim db As DAO.Database
Dim qdfItem As DAO.QueryDef
Dim rsItem As DAO.Recordset
Dim rsStock As DAO.Recordset
Dim strItem As String
Dim strSQL As String
Dim Year As String
Dim intSheet As Integer
Dim intRow As Integer
Dim intRecords As Integer
Dim StockTemplatePath As String
Dim StockSaveLocation As String
Dim recipient As String
Dim issues As Integer
Dim sheetname As String
Dim i As Integer
'Dim intRecords As Integer

intRecords = DCount("*", "qryStockCheck")
If intRecords > 0 Then ' checks that there is a record
    Me.cboYear.SetFocus
    Year = Me.cboYear.Text
    If Year <> "" Then ' Checks that an accounting year has been selected
        Set db = CurrentDb
        Set qdfItem = db.QueryDefs("qryStockItems")
        Set rsItem = qdfItem.OpenRecordset ' Summary of items in stock
        rsItem.MoveLast
        rsItem.MoveFirst
        If Not (rsItem.BOF And rsItem.EOF) Then ' Check that records exist
            intSheet = 1 ' Starting sheet in the workbook
            StockTemplatePath = getpath(db.Name) & "Templates\StockVoucher.xlt"
            StockSaveLocation = getpath(db.Name) & "Vouchers\Stock\Stock" & Year & ".xls"
        
            ' Creates Excel object
            Set objXLApp = CreateObject("Excel.Application")
            Set objXLApp = New Excel.Application
            Set objXLWb = objXLApp.Workbooks.Open(StockTemplatePath)
        
            intRecords = rsItem.RecordCount ' Number of worksheets required
            ' Copies number of worksheets required
            Set objXLWs = objXLWb.Worksheets(intSheet)
            For i = 1 To (intRecords - 1)
                objXLWb.Worksheets(i).Copy after:=objXLWb.Worksheets(i)
            Next i
        
            rsItem.MoveNext ' Moves past the first record, which is a dummy one
            ' Loops through each item description
            While Not rsItem.EOF ' Check for end of recordset
                intRow = 8 ' Starting row to be populated
                strItem = rsItem!Description ' Item description
            
                Set objXLWs = objXLWb.Worksheets(intSheet) ' Sets active Worksheet
            
                ' SQL Query for each Item
                strSQL = "SELECT tblOrderRecord.Description, Sum(tblOrderRecord.Qty) AS SumOfQty, tblOrderRecord.ReceiptVoucherNo, tblOrderRecord.DateRecieved, tblOrderRecord.RecivedFrom, tblOrderRecord.CollarNo, tblOrderRecord.StaffNo,tblOrderRecord.Station, tblOrderRecord.Year" & _
                " FROM tblOrderRecord WHERE (((tblOrderRecord.Recieved) = Yes) And ((tblOrderRecord.Deficit) = No) And ((tblOrderRecord.ReportedConsumed) = No) And ((tblOrderRecord.Year) = '" & Year & "'))" & _
                " GROUP BY tblOrderRecord.Description, tblOrderRecord.ReceiptVoucherNo, tblOrderRecord.DateRecieved, tblOrderRecord.RecivedFrom, tblOrderRecord.CollarNo, tblOrderRecord.StaffNo, tblOrderRecord.Station, tblOrderRecord.Year" & _
                " HAVING (((tblOrderRecord.Description) = '" & strItem & "')) ORDER BY tblOrderRecord.DateRecieved;"
            
            
                Set rsStock = db.OpenRecordset(strSQL, dbOpenDynaset) ' individual instances of items in stock
                ' Loops through each individual instance of Item
                While Not rsStock.EOF ' Check for end of recordset
                    If rsStock!Station = 0 And rsStock!CollarNo = 0 Then ' Checks for issue
                        issues = 0
                        recipient = ""
                    Else
                        If rsStock!CollarNo = 0 Then ' Checks for person or station
                            recipient = rsStock!Station
                        Else
                            recipient = rsStock!StaffNo
                        End If
                        issues = rsStock!SumOfQty
                    End If
                
                    With objXLWs ' Populates the worksheet with recordset data
                        .Cells(intRow, 1) = (rsStock!ReceiptVoucherNo)
                        .Cells(intRow, 3) = (rsStock!DateRecieved)
                        .Cells(intRow, 4) = (rsStock!RecivedFrom)
                        .Cells(intRow, 5) = (recipient)
                        .Cells(intRow, 7) = (rsStock!SumOfQty)
                        .Cells(intRow, 8) = (issues)
                        .Cells(4, 4) = (rsStock!Description)
                        .Cells(1, 9) = (rsStock!Year)
                    End With
                
                    intRow = intRow + 1 ' Increments the Row number
                    rsStock.MoveNext ' Move to the next row
                Wend

                sheetname = Left(strItem, 20) ' Shorten worksheet name
                objXLWs.Name = (sheetname) ' Name sheet according to item description
            
                intSheet = intSheet + 1 ' Increment sheet number
                rsItem.MoveNext ' Move to next item
            Wend
        End If
        objXLApp.Visible = True ' Show Workbook
        objXLWb.SaveAs (StockSaveLocation) ' Save Workbook
    
        ' Clear object variables from memory
        Set objXLWs = Nothing
        Set objXLWb = Nothing
        Set objXLApp = Nothing
        rsStock.Close
        Set rsStock = Nothing
        rsItem.Close
        Set rsItem = Nothing
    Else
        MsgBox "Select an Accounting Year" ' Prompt user to enter Year
    End If
Else
    MsgBox ("There are no items in Stock")
End If

End Sub

It seems that a workbook is left open somehow. But i cannot see where i have failed to clean up
after myself.

Be grateful if someone could have a look and tell where i have been stupid.

I have been looking at the problem soooo long i am going in circles..

 

[chriswies]

You are opening the same Workbook and let the code run on the workbook.
So it seems to be clear the objxlws.name = sheetname will crash

btw:
Set objXLApp = CreateObject("Excel.Application")
Set objXLApp = New Excel.Application

This is redundant. Kill one line.
Christoph

 

[chriswies]

Sorry, I now saw StockTemplatePath and StockSaveLocation. That is not the reason. But check on the double objXLApp.
Because you loop through your code and each loop reassigns objXLApp
-> slow
-> within the loop, the Template is still open and NOT saved, but renamed

Christoph

 

[trebor3900]

Worksheets seem to be problem

Thanks for your time

For some reason the routine is overwriting the Excel template and not creating a new xls document.

The routine runs fine if i use a clean template for it to write to.

Do not know what is wrong but the only way i know how to go is to reverse the routine to delete all extra worksheets created from the routine prior to it running

 

[chriswies]

Please post your revised Code

Please post your revised Code

 

[Bat17]

Set objXLWb = objXLApp.Workbooks.Open(StockTemplatePath)

Should be

Set objXLWb = objXLApp.Workbooks.Add(StockTemplatePath)


HTH

Peter

 

[tkpstock]

I don't know how many items are in your database, but adding a new worksheet for each record seems extreme. Excel can theoretically hold 255 worksheets in a workbook, but that depends on what objects the sheets have in them. Let's hope that the number of items remains under 255.

I notice you set the sheet name to the value of strItem (which you shorten from the item description). Are there any item descriptions with the same first twenty letters? This would cause that problem. The first twenty letters of every item must be unique in order for that to work.

The reason your workbook is still open is that you're not closing it. Before setting them to nothing, try:

        objXLWb.Close SaveChanges:=True
        objXLApp.Quit

Then you don't need to explicity make the workbook visible and save it.

This just an addition to the other things mentioned above.

HTH

 

[trebor3900]

That did the trick. It now opens a separate xls file leaving the template intact....Thanks guys, you saved me a breakdown...Cheers