Copying and pasting new worksheets

[trebor3900]

I have a button in Access that populates the worksheets of a template in Excel. Each instance of a particular item in my table is added to its own worksheet and the worksheet is renamed according to the item description.

This works fine but only if there are enough worksheets in the workbook already. At the moment i have a lot of worksheets in the workbook pre-formatted to accept the data.

This is messy and i would like to add the code to enable me to copy an empty pre-formatted worksheet and paste it into the workbook as required.

My code so far

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

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
        'intRow = 8 ' Starting row to be populated
        intSheet = 1 ' Starting sheet in the workbook
        StockTemplatePath = getpath(db.Name) & "Templates\StockVoucher.xlt"
        StockSaveLocation = getpath(db.Name) & "Vouchers\Stock\Stock" & Year & ".xls"
        
        Set objXLApp = CreateObject("Excel.Application")
        Set objXLApp = New Excel.Application
        Set objXLWb = objXLApp.Workbooks.Open(StockTemplatePath)
        
        While Not rsItem.EOF ' Check for end of recordset
            intRow = 8 ' Starting row to be populated
            intRecords = rsItem.RecordCount ' Number of worksheets required
            strItem = rsItem!Description ' Item description
            Set objXLWs = objXLWb.Worksheets(intSheet)
            
            strSQL = "SELECT tblOrderRecord.Description, tblOrderRecord.Qty, tblOrderRecord.Recieved, tblOrderRecord.ReceiptVoucherNo, tblOrderRecord.DateRecieved, tblOrderRecord.RecivedFrom, tblOrderRecord.Deficit, tblOrderRecord.ReportedConsumed, tblOrderRecord.CollarNo, tblOrderRecord.StaffNo, tblOrderRecord.Station, tblOrderRecord.Year" & _
            " FROM tblOrderRecord WHERE (((tblOrderRecord.Description) = '" & strItem & "') And ((tblOrderRecord.Recieved) = Yes) And ((tblOrderRecord.Deficit) = No) And ((tblOrderRecord.ReportedConsumed) = No) And ((tblOrderRecord.year) = '" & Year & "'))" & _
            " ORDER BY tblOrderRecord.DateRecieved;" ' Query for Stock Record
            
            Set rsStock = db.OpenRecordset(strSQL, dbOpenDynaset) ' individual instances of items in stock
            While Not rsStock.EOF ' Check for end of recordset
                'MsgBox "Record " & rsStock!Description
                
                If rsStock!Station = 0 And rsStock!CollarNo = 0 Then
                    issues = 0
                    recipient = ""
                Else
                    If rsStock!CollarNo = 0 Then
                        recipient = rsStock!Station
                    Else
                        recipient = rsStock!StaffNo
                    End If
                    issues = rsStock!Qty
                End If
                
                With objXLWs
                    .Cells(intRow, 1) = (rsStock!ReceiptVoucherNo)
                    .Cells(intRow, 3) = (rsStock!DateRecieved)
                    .Cells(intRow, 4) = (rsStock!RecivedFrom)
                    .Cells(intRow, 5) = (recipient)
                    .Cells(intRow, 7) = (rsStock!Qty)
                    .Cells(intRow, 8) = (issues)
                    .Cells(4, 4) = (rsStock!Description)
                    .Cells(1, 9) = (rsStock!Year)
                End With
                
                intRow = intRow + 1
                rsStock.MoveNext
            Wend
            'MsgBox "End of item"
            sheetname = Left(strItem, 15) ' 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
    objXLWb.SaveAs (StockSaveLocation)
    objXLWb.Close
    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"
End If

End Sub

 

[trebor3900]

Found it

Just in case anyone is interested, i have found the solution to my problem...

' Code to Copy worksheets required
        Set objXLWs = objXLWb.Worksheets(intSheet)
        For i = 1 To (intRecords - 1)
            objXLWb.Worksheets(i).Copy after:=objXLWb.Worksheets(i)
        Next i