code running way too slow...any suggestions?

***continued from Part 1***
Code:
****************************
*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