My Assistant
![]() ![]() |
|
|
Mar 28 2012, 07:37 AM
Post
#1
|
|
|
New Member Posts: 2 |
Hi,
I'm not sure if anyone out there can help. I have some VBA code within Access 2010 that creates Excel spreadsheets of invoices. For some reason, the more spreadsheets it creates, the slower the spreadsheets are created to the point that Access crashes. The section of code that creates the spreadsheets is below. I would be grateful of any advise anyone can offer. Regards, - Sean FileCopy strTemplate, strFileName Set objBook = GetObject(strFileName) Set objSheet = objBook.Worksheets(1) intTenantNo = DLookup("TblTenants_ID", "tblTenancyDetails", "[TenancyNo] = " & rstRentTable("TenancyNo")) strBillingAddress = rstRentTable("BillingAddress") With objSheet If intOption = 1 Then If rstRentTable("EffectivePaymentDate") >= dtInvoiceDate Then dtFinalDate = rstRentTable("EffectivePaymentDate") Else dtFinalDate = dtInvoiceDate End If '.Cells(9, 7) = rstRentTable("EffectivePaymentDate") ' Invoice Due Date .Cells(9, 7) = dtFinalDate Else .Cells(9, 7) = rstRentTable("PaymentDate") ' Invoice Due Date End If .Cells(10, 7) = strInvoice ' Invoice Number .Cells(11, 7) = dtInvoiceDate ' Invoice Date .Cells(13, 7) = rstRentTable("RefNo") ' Shere Ref No .Cells(14, 7) = rstRentTable("TenantCellRef") ' Operator Cell No .Cells(17, 1) = "Ref: " & rstRentTable("Reference") 'Re: O2 install at High Man .Cells(18, 1) = "Address: " & DLookup("[Address]", "tbloriginaldata", _ "[TenancyNo]=" & rstRentTable("TenancyNo")) ' Address of site .Cells(22, 1) = rstRentTable("Description") ' Description of what is being invoiced .Cells(22, 6) = DLookup("[TaxRate]", "tblTaxCodes", "[TaxCode]='" & rstRentTable("TaxCode") & "'") * 100 'VAT Rate .Cells(22, 7) = CCur(rstRentTable("Income")) ' Income for site .Cells(22, 8) = CCur(rstRentTable("VatValue")) 'VAT on Sale If (CCur(rstRentTable("Income")) + CCur(rstRentTable("VatValue"))) < 0 Then .Cells(10, 6) = "Credit Note No:" ' MsgBox rstRentTable("Tenant") varAddress = "" varAddress = GetTenantAddress(intTenantNo, strBillingAddress) .Cells(9, 1) = varAddress ' Invoice Address .Cells(35, 1) = rstRentTable("AdHocText") rstRentTable.Edit rstRentTable("InvoiceNo").Value = strInvoice rstRentTable("InvoiceDate").Value = dtInvoiceDate rstRentTable.Update End With objBook.Save objBook.Application.DisplayAlerts = True objBook.Windows(1).Visible = True objBook.Close savechanges:=True Set objSheet = Nothing Set objBook = Nothing GoTo EndOfDoLoop EndOfDoLoop: rstRentTable.MoveNext Loop |
|
|
|
Mar 28 2012, 07:53 AM
Post
#2
|
|
|
UtterAccess VIP Posts: 1,472 |
Nothing is glaring at me, but this is obviously not the full code as it references rstRentTable and it is not defined in the code you supplied, it has a loop which we do not have defined, so don't know what is going on exactly. You really should give us the full picture for us to take a proper look at.
Also, please indent and add proper error handling CODE Sub YourProcName() On Error GoTo Error_Handler FileCopy strTemplate, strFileName Set objBook = GetObject(strFileName) Set objSheet = objBook.Worksheets(1) intTenantNo = DLookup("TblTenants_ID", "tblTenancyDetails", "[TenancyNo] = " & rstRentTable("TenancyNo")) strBillingAddress = rstRentTable("BillingAddress") With objSheet If intOption = 1 Then If rstRentTable("EffectivePaymentDate") >= dtInvoiceDate Then dtFinalDate = rstRentTable("EffectivePaymentDate") Else dtFinalDate = dtInvoiceDate End If '.Cells(9, 7) = rstRentTable("EffectivePaymentDate") ' Invoice Due Date .Cells(9, 7) = dtFinalDate Else .Cells(9, 7) = rstRentTable("PaymentDate") ' Invoice Due Date End If .Cells(10, 7) = strInvoice ' Invoice Number .Cells(11, 7) = dtInvoiceDate ' Invoice Date .Cells(13, 7) = rstRentTable("RefNo") ' Shere Ref No .Cells(14, 7) = rstRentTable("TenantCellRef") ' Operator Cell No .Cells(17, 1) = "Ref: " & rstRentTable("Reference") 'Re: O2 install at High Man .Cells(18, 1) = "Address: " & DLookup("[Address]", "tbloriginaldata", _ "[TenancyNo]=" & rstRentTable("TenancyNo")) ' Address of site .Cells(22, 1) = rstRentTable("Description") ' Description of what is being invoiced .Cells(22, 6) = DLookup("[TaxRate]", "tblTaxCodes", "[TaxCode]='" & rstRentTable("TaxCode") & "'") * 100 'VAT Rate .Cells(22, 7) = CCur(rstRentTable("Income")) ' Income for site .Cells(22, 8) = CCur(rstRentTable("VatValue")) 'VAT on Sale If (CCur(rstRentTable("Income")) + CCur(rstRentTable("VatValue"))) < 0 Then .Cells(10, 6) = "Credit Note No:" ' MsgBox rstRentTable("Tenant") varAddress = "" varAddress = GetTenantAddress(intTenantNo, strBillingAddress) .Cells(9, 1) = varAddress ' Invoice Address .Cells(35, 1) = rstRentTable("AdHocText") rstRentTable.Edit rstRentTable("InvoiceNo").Value = strInvoice rstRentTable("InvoiceDate").Value = dtInvoiceDate rstRentTable.Update End With objBook.Save objBook.Application.DisplayAlerts = True objBook.Windows(1).Visible = True objBook.Close savechanges:=True Set objSheet = Nothing Set objBook = Nothing GoTo EndOfDoLoop EndOfDoLoop: rstRentTable.MoveNext Loop Error_Handler_Exit: On Error Resume Next Set objSheet = Nothing Set objBook = Nothing Exit Sub Error_Handler: MsgBox Err.Number & vbcrlf & Err.Description & vbcrlf & sModName & "/YourProcName" Resume Error_Handler_Exit End Sub Depending on your loop, if it is adding sheets to workbook and saving each time, the save process will progressively get slower, so this could be part of the issue, but this is pure speculation without seeing the full code |
|
|
|
Mar 28 2012, 08:04 AM
Post
#3
|
|
|
New Member Posts: 2 |
HI Daniel
I was try to cut corners slightly by posting only the section that seems to be causing issues, I have put the whole procedure in below. Regards, - Sean CODE Public Function CreateInvoicesExcel(intOption As Integer) As Integer
Dim intRailsiteInv As Integer, intRadiositeInv As Integer, intWatersiteInv As Integer, intInvNo As Integer, intCompanyNo As Integer Dim intDefaultInvNo As Integer, intTenantNo As Integer, intQS4Inv, intSanity As Integer, intError As Integer, intNoInvoices As Integer Dim dbCurrDb As dao.Database, rstRentTable As dao.Recordset Dim strTemplate As String, strPathname As String, strFileName As String, strInvoice As String, strBillingAddress As String Dim varAddress As Variant Dim dtInvoiceDate As Date, dtFinalDate As Date Dim objBook As Excel.Workbook Dim objSheet As Excel.Worksheet If MsgBox("Are you sure that you are ready to produce current batch of invoices", vbYesNo, "Confirm Process") _ = vbNo Then Exit Function Set dbCurrDb = CurrentDb Select Case intOption Case Is = 1 Set rstRentTable = dbCurrDb.OpenRecordset("tblMonthsInvoicing", dbopendynaset) Case Is = 2 Set rstRentTable = dbCurrDb.OpenRecordset("tblAdHocInvoicing", dbopendynaset) End Select 'Sanity Checks intError = 0 intnoinvoice = 0 If rstRentTable.RecordCount = 0 Then MsgBox "There are no invoices to be raised!", vbCritical, "Error" intError = 1 GoTo EndofCreateInvoices End If intSanity = 0 Do Until rstRentTable.EOF If rstRentTable("ToBeInvoiced") = -1 Then If rstRentTable("nextpaymentdate") = "" Then intSanity = 1 'intError = 1 End If If IsNull(rstRentTable("nextpaymentdate")) = True Then If intOption = 1 Then intSanity = 1 'intError = 1 End If End If If IsNull(rstRentTable("Income")) = True Or IsNull(rstRentTable("VATValue")) = True Then intSanity = 2 'intError = 2 End If If rstRentTable("Income") + rstRentTable("VATValue") = 0 Then intSanity = 2 'intError = 2 End If End If If rstRentTable("ToBeInvoiced") = -1 Then intNoInvoices = intNoInvoices + 1 If intSanity >= 1 Then Exit Do rstRentTable.MoveNext Loop If intSanity = 2 Then MsgBox "One Or More Invoices Have Not Got Valid Amounts Entered For Invoice Value or VAT - Please Review!", vbCritical, "Error" intError = 1 GoTo EndofCreateInvoices End If If intOption = 2 Then GoTo EndOfSanityCheck If intSanity = 1 Then MsgBox "One Or More Invoices Have Not Got Dates Entered For The Next Invoice To Be Raised - Please Review!", vbCritical, "Error" intError = 1 GoTo EndofCreateInvoices End If EndOfSanityCheck: If intNoInvoices = 0 Then MsgBox "There Are No Invoices Marked To Be Raised - Please Review!", vbCritical, "Error" intError = 1 GoTo EndofCreateInvoices End If rstRentTable.MoveFirst 'End of Sanity Check strPathname = DLookup("[Location]", "tblLocation", "[Database] = 'Backend'") intDefaultInvNo = DLookup("[LastInvoiceNo]", "tblLatestInvoiceNo", "[Company] = '" & "Radiosite" & "'") intRadiositeInv = InputBox("Enter first invoice number to be used for Radiosite: " & Chr(13) _ & "(The last one used was " & intDefaultInvNo, "Radiosite", intDefaultInvNo + 1) intDefaultInvNo = DLookup("[LastInvoiceNo]", "tblLatestInvoiceNo", "[Company] = '" & "Railsite" & "'") intRailsiteInv = InputBox("Enter first invoice number to be used for Railsite: " & Chr(13) _ & "(The last one used was " & intDefaultInvNo, "Railsite", intDefaultInvNo + 1) intDefaultInvNo = DLookup("[LastInvoiceNo]", "tblLatestInvoiceNo", "[Company] = '" & "Watersite" & "'") intWatersiteInv = InputBox("Enter first invoice number to be used for Watersite: " & Chr(13) _ & "(The last one used was " & intDefaultInvNo, "Watersite", intDefaultInvNo + 1) intDefaultInvNo = DLookup("[LastInvoiceNo]", "tblLatestInvoiceNo", "[Company] = '" & "QS4" & "'") intQS4Inv = InputBox("Enter first invoice number to be used for QS4: " & Chr(13) _ & "(The last one used was " & intDefaultInvNo, "QS4", intDefaultInvNo + 1) dtInvoiceDate = InputBox("Enter the Date that these invoices are to be issued on: ", "Invoice Date") If IsNull(dtInvoiceDate) = True Then dtInvoiceDate = Date rstRentTable.MoveFirst Do While Not rstRentTable.EOF If rstRentTable("ToBeInvoiced").Value <> -1 Then GoTo EndOfDoLoop intCompanyNo = DLookup("[CompanyNo]", "tblPortfolio", "[Portfolio]='" & rstRentTable("invoicingDepartment") & "'") Select Case rstRentTable("InvoicingDepartment") Case Is = "Radiosite" strTemplate = strPathname & "\InvoiceTemplates\RadiositeRent(Blank).xls" strInvoice = intCompanyNo & "/" & Right(Date, 2) & "/" & intRadiositeInv strFileName = strPathname & "\Invoices\" & intCompanyNo & "." & Right(Date, 2) & "." & intRadiositeInv & ".xls" intInvNo = intRadiositeInv intRadiositeInv = intRadiositeInv + 1 Case Is = "Railsite" strTemplate = strPathname & "\InvoiceTemplates\RailsiteRent(Blank).xls" strInvoice = intCompanyNo & "/" & Right(Date, 2) & "/" & intRailsiteInv strFileName = strPathname & "\Invoices\" & intCompanyNo & "." & Right(Date, 2) & "." & intRailsiteInv & ".xls" intInvNo = intRailsiteInv intRailsiteInv = intRailsiteInv + 1 Case Is = "Watersite" strTemplate = strPathname & "\InvoiceTemplates\WatersiteRent(Blank).xls" strInvoice = intCompanyNo & "/" & Right(Date, 2) & "/" & intWatersiteInv strFileName = strPathname & "\Invoices\" & intCompanyNo & "." & Right(Date, 2) & "." & intWatersiteInv & ".xls" intInvNo = intWatersiteInv intWatersiteInv = intWatersiteInv + 1 Case Is = "QS4" strTemplate = strPathname & "\InvoiceTemplates\QS4Rent(Blank).xls" strInvoice = intCompanyNo & "/" & Right(Date, 2) & "/" & intQS4Inv strFileName = strPathname & "\Invoices\" & intCompanyNo & "." & Right(Date, 2) & "." & intQS4Inv & ".xls" intInvNo = intQS4Inv intQS4Inv = intQS4Inv + 1 Case Else MsgBox "Please confirm which department is to invoice for site ref: " _ & rstRentTable("RefNo") intError = 1 GoTo EndofCreateInvoices End Select FileCopy strTemplate, strFileName Set objBook = GetObject(strFileName) Set objSheet = objBook.Worksheets(1) intTenantNo = DLookup("TblTenants_ID", "tblTenancyDetails", "[TenancyNo] = " & rstRentTable("TenancyNo")) strBillingAddress = rstRentTable("BillingAddress") With objSheet If intOption = 1 Then If rstRentTable("EffectivePaymentDate") >= dtInvoiceDate Then dtFinalDate = rstRentTable("EffectivePaymentDate") Else dtFinalDate = dtInvoiceDate End If '.Cells(9, 7) = rstRentTable("EffectivePaymentDate") ' Invoice Due Date .Cells(9, 7) = dtFinalDate Else .Cells(9, 7) = rstRentTable("PaymentDate") ' Invoice Due Date End If .Cells(10, 7) = strInvoice ' Invoice Number .Cells(11, 7) = dtInvoiceDate ' Invoice Date .Cells(13, 7) = rstRentTable("RefNo") ' Shere Ref No .Cells(14, 7) = rstRentTable("TenantCellRef") ' Operator Cell No .Cells(17, 1) = "Ref: " & rstRentTable("Reference") 'Re: O2 install at High Man .Cells(18, 1) = "Address: " & DLookup("[Address]", "tbloriginaldata", _ "[TenancyNo]=" & rstRentTable("TenancyNo")) ' Address of site .Cells(22, 1) = rstRentTable("Description") ' Description of what is being invoiced .Cells(22, 6) = DLookup("[TaxRate]", "tblTaxCodes", "[TaxCode]='" & rstRentTable("TaxCode") & "'") * 100 'VAT Rate .Cells(22, 7) = CCur(rstRentTable("Income")) ' Income for site .Cells(22, 8) = CCur(rstRentTable("VatValue")) 'VAT on Sale If (CCur(rstRentTable("Income")) + CCur(rstRentTable("VatValue"))) < 0 Then .Cells(10, 6) = "Credit Note No:" ' MsgBox rstRentTable("Tenant") varAddress = "" varAddress = GetTenantAddress(intTenantNo, strBillingAddress) .Cells(9, 1) = varAddress ' Invoice Address .Cells(35, 1) = rstRentTable("AdHocText") rstRentTable.Edit rstRentTable("InvoiceNo").Value = strInvoice rstRentTable("InvoiceDate").Value = dtInvoiceDate rstRentTable.Update End With objBook.Save objBook.Application.DisplayAlerts = True objBook.Windows(1).Visible = True objBook.Close savechanges:=True Set objSheet = Nothing Set objBook = Nothing GoTo EndOfDoLoop EndOfDoLoop: rstRentTable.MoveNext Loop Set rstRentTable = Nothing Set rstRentTable = dbCurrDb.OpenRecordset("tblLatestInvoiceno", dbopendynaset) With rstRentTable .MoveFirst Do While Not rstRentTable.EOF Select Case rstRentTable("Company") Case Is = "Radiosite" .Edit rstRentTable("LastInvoiceNo").Value = intRadiositeInv - 1 .Update Case Is = "Railsite" .Edit rstRentTable("LastInvoiceNo").Value = intRailsiteInv - 1 .Update Case Is = "Watersite" .Edit rstRentTable("LastInvoiceNo").Value = intWatersiteInv - 1 .Update Case Is = "QS4" .Edit rstRentTable("LastInvoiceNo").Value = intQS4Inv - 1 .Update End Select rstRentTable.MoveNext Loop End With GoTo EndofCreateInvoices EndofCreateInvoices: Set rstRentTable = Nothing Set rstRentTable = Nothing Set dbCurrDb = Nothing If intError = 0 Then Select Case intOption Case Is = 1 ProduceSageFile dtInvoiceDate ' UpdateNextInvDate Case Is = 2 ProduceSageAdHocFile dtInvoiceDate End Select CreateInvoicesExcel = 0 Else CreateInvoicesExcel = 1 End If End Function This post has been edited by seankavanagh: Mar 28 2012, 08:08 AM |
|
|
|
Mar 28 2012, 09:04 AM
Post
#4
|
|
|
UtterAccess Ruler Posts: 1,090 |
CODE Set objBook = GetObject(strFileName) It seems you are always creating and closing an instance of Excel object when you do the above code. Why not just put a reference to Excel.Application once after the declaration of variables Dim xlApp as Excel.Application Set xlApp = New Excel.Application Then on the code on the block, replace it with: set objBook = xlApp.Workbooks.Open(strFileName) Then before the Function Ends xlApp.Close set xlApp = Nothing. This post has been edited by arnelgp: Mar 28 2012, 09:05 AM |
|
|
|
![]() ![]() |
|
Go to Top · Lo-Fi Version | Time is now: 25th May 2013 - 02:21 PM |