turbo charge this code??? - Part 2

[kkozar]

code running way too slow...any suggestions?

***continued from Part 1***

****************************
*first called module*
' Purpose   :  Creates the PO Detail spreadsheet.
'               If the FilePath is not blank, saves to file, otherwise show to user.
'               Depends on external template file, must be in the same folder as this app.
'---------------------------------------------------------------------------------------
'
Public Function PODetail2Excel(VENDID As Long, FilePath As String) As Boolean
    
    On Error GoTo PODetail2Excel_Error
   
    Dim XA As Excel.Application
    Dim XW As Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim rst As DAO.Recordset
    Dim I As Integer
    Dim sFilePath As String
    Dim sDateRange As String
    Dim bRet As Boolean
    Dim oFs As New FileSystemObject
    
    DoCmd.Hourglass (True)
    bRet = True
    'Get Date Range
    Set rst = CurrentDb.OpenRecordset("Select HistBeginDate, HistEndDate From tblReportingDateRanges;")
    
    sDateRange = rst("HistBeginDate") & " - " & rst("HistEndDate")
    
    rst.Close
    
    sFilePath = GetFilePath("ExcelExportTemplate")
    
    
    'make sure file exists and looks like a .xls
    If Not oFs.FileExists(sFilePath) Then
      Err.Raise vbObjectError + 10, "PODetail2Excel", "Please make sure the ExcelExportTemplate parameter is set on the File Paths tab of the admin screen"
    End If
    
    If Right(sFilePath, 4) <> ".xls" Then
      Err.Raise vbObjectError + 10, "PODetail2Excel", "Excel Export Template must be an .xls file: " & vbCrLf & sFilePath & vbCrLf & "Check its setting on the FilePaths tab of the admin screen"
    End If
    
    'Open a new workbook, using the formatted file as a template.
    Set XA = CreateObject("Excel.Application")
    
    Set XW = XA.Workbooks.Add(sFilePath)
    
    '==================================================================================
    'Timeliness Worksheet
    '==================================================================================
    Set WS = XA.Worksheets("Timeliness")
    WS.Activate
    
    Set rst = CurrentDb.OpenRecordset("Select * From qryFinedPOs Where VENDID = " & VENDID & ";")
    
    With WS
        'header info for page.  Lookup up vendor name separately in case rst is empty
        .Range("D6").Value = DLookup("VENDNAME", "tblVendors", "VENDID = " & VENDID)
        .Range("D4").Value = VENDID
        .Range("I2").Value = Now()
        .Range("I4").Value = sDateRange
        
        I = 11
        
        Do Until rst.EOF
            
            .Range("B" & I).EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
            .Range("B" & I).Value = rst("PO Number")
            .Range("C" & I).Value = rst("ShipmentTypeDesc")
            .Range("D" & I).Value = rst("Required Date")
            .Range("E" & I).Value = rst("Received Date")
            .Range("F" & I).Value = rst("Days Late")
            .Range("G" & I).Value = rst("PO Cost")
            .Range("H" & I).Value = rst("Status")
            .Range("I" & I).Value = rst("Fine")
            '.Range("B" & I + 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            
            I = I + 1
            rst.MoveNext
        Loop
        
        'Adjust the total column to cover the output rows
        .Range("I8").Formula = "=SUM(I11:I" & I & ")"
    
    End With
    
    rst.Close
    
    '==================================================================================
    'Accuracy Worksheet
    '==================================================================================
    Set WS = XA.Worksheets("Accuracy")
    WS.Activate
    
    Set rst = CurrentDb.OpenRecordset("Select * From qryFinedPOItems Where VENDID = " & VENDID & ";")
    
     With WS
        'header info for page.  Lookup up vendor name separately in case rst is empty
        .Range("D6").Value = DLookup("VENDNAME", "tblVendors", "VENDID = " & VENDID)
        .Range("D4").Value = VENDID
        .Range("J2").Value = Now()
        .Range("J4").Value = sDateRange
        
        I = 11
        
        Do Until rst.EOF
            
            .Range("B" & I).EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
            .Range("B" & I).Value = rst("PO Number")
            .Range("C" & I).Value = rst("SKU")
            .Range("D" & I).Value = rst("Quantity Ordered")
            .Range("E" & I).Value = rst("Quantity Received")
            .Range("F" & I).Value = rst("Variance")
            .Range("G" & I).Value = rst("Variance Reason")
            .Range("H" & I).Value = rst("PO Cost")
            .Range("I" & I).Value = rst("Status")
            .Range("J" & I).Value = rst("Fine")
            '.Range("B" & I + 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            
            I = I + 1
            rst.MoveNext
        Loop
        
        'Adjust the total column to cover the output rows
        .Range("J8").Formula = "=SUM(J11:J" & I & ")"

    End With
    
    '==================================================================================
    'If a file path was given, save the document, otherwise show it to user.
    '==================================================================================
    
    If FilePath <> "" Then
        'Automatically overwrite any existing files.
        If Dir(FilePath) <> "" Then
            Kill FilePath
        End If
        XW.SaveAs (FilePath)
        XA.Quit
        Set XA = Nothing
    Else
        XA.Visible = True
    End If
    
PODetail2Excel_Error:

    If Err.Number <> 0 Then
        bRet = False
        ProcessError Err.Number, Err.Description, "PODetail2Excel", "Module: modExcel"
        XA.Quit
        Set XA = Nothing
    End If
  
  On Error Resume Next
  Set oFs = Nothing
  DoCmd.Hourglass (False)
  PODetail2Excel = bRet

End Function
****************************
*second called module***
Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const MAX_WAIT_TIME = 20000

'---------------------------------------------------------------------------------------
' Procedure : PrintPdf
' Author    : xxxx
' Date      : 7/13/2008
' Purpose   : Prints the specified report using the report's printer settings
'
'---------------------------------------------------------------------------------------

Public Function PrintPdf(sReportName As String, sFilter As String, _
                    sTempPDFDir As String, sExportPDFDir As String, sExportFile As String) As Boolean
   
  On Error GoTo ERR_PrintPDF
  
  Dim sTempFile
  Dim lPrevFileSizeCheck As Long
  Dim lWaitTime As Long
  Dim bRet As Boolean
     
  lPrevFileSizeCheck = 0
  lWaitTime = 0
  bRet = True
  
  If Not CreateWindowsDirectory(sTempPDFDir) _
     Or Not CreateWindowsDirectory(sExportPDFDir) Then
   
   Err.Raise vbObjectError + 1, "PrintPDF", "Could not find or create required folders: " & vbCrLf & _
                                sTempPDFDir & vbCrLf & _
                                sExportPDFDir & vbCrLf

  End If
  
  sTempFile = sTempPDFDir & sReportName & ".pdf"
  
  If Dir(sTempFile) <> "" Then
    Kill sTempFile
  End If
    
  'print the report using its settings
  DoCmd.OpenReport sReportName, acNormal, , sFilter
  
  ' wait for the temp file to be created
  Do While Len(Dir(sTempFile)) = 0
      Sleep (500)
  Loop
  
  Sleep (1500)
  
  ' stay here until the temp file stops growing
  Do While FileLen(sTempFile) <> lPrevFileSizeCheck
      Sleep (500)
      lWaitTime = lWaitTime + 500
      lPrevFileSizeCheck = FileLen(sTempFile)
      
      If lWaitTime > MAX_WAIT_TIME Then
        Err.Raise vbObjectError + 1, "PrintPDF", "Timeout expired creating pdf of " & sReportName & " with filter " & sFilter
      End If
      
  Loop
  
  If Dir(sExportPDFDir & sExportFile) <> "" Then
    Kill sExportPDFDir & sExportFile
  End If
   
  Name sTempFile As sExportPDFDir & sExportFile
  
  DoCmd.Close acReport, "sReportName"
      
ERR_PrintPDF:
  If Err.Number <> 0 Then
    bRet = False
    ProcessError Err.Number, Err.Description, "PrintPDF", "modPDF"
  End If
      
  PrintPdf = bRet
      
End Function

[TDQWERTY]

Make sure that qryFinedPOs.VENDID is indexed;
qryFinedPOItems.VENDID too;

What i wrote in part 1 might help..
good luck

[leinad31]

Aside from having proper indexes you can also join the tables sorted on vendor ID rather than querying them separately, then simply keep track of last vendor ID... if vendor ID changes (compared to previous record) then it is your signal to generate another Excel/PDF file.

Currently you are repeatedly scanning through tblReportingDateRanges, qryFinedPOs, qryFinedPOItems for each vendor ID. If you have 100 vendor IDs then you scan said tables 100 times to get a subset. With a join you read all tables just once. Assume last two tables had 1000 records each, instead of reading 100 + 1000 + 1000 + 1 (from tblReportingDateRanges) = 2101 records, you end up with 100 + (100 * 1000) + (100 * 1000) + 100 * 1 = 200,101 record access. Setting up indexes minimizes record access but you still incur overhead from repeatedly accessing the table index (since table index faster compared to table row access).

This is common mistake by programmer's used to iterative logic rather than employing set based logic... this is evident in your code wherein you nested the SQL queries via loops (iterative logic) rather than doing a join on vendor ID from the very start.

[Pradeep1210]

Having a quick glance at the code, I think this is where it is slowing down

  ' wait for the temp file to be created
  Do While Len(Dir(sTempFile)) = 0
      Sleep (500)
  Loop
  
  Sleep (1500)

You are forcefully making it sleep even if the file might have been created. So instead see if replacing it with the following code makes any difference:

  ' wait for the temp file to be created
  Do While Len(Dir(sTempFile)) = 0
      DoEvents
  Loop