Faster way to write to Excel?

[Abraxus]

I have some code that writes out a query to Excel using a template file with headers in the first 2 rows.

Problem is that it is INCREDIBLY slow...like turtle slow. Like a turtle in molasses slow. Did I mention it was slow?

For example, it took 8 minutes to write 3,340 records, 42 minutes to write 21,432 records, and 1 hour 46 minutes to write 40,864 records.

I've already made Visible = false and ScreenUpdating = false.

Surely there must be a faster method.

Any suggestions?

Code I use is below:

Code: Select all

Sub OutputVPReport(strVPIn As String, blnSendEmail As Boolean)
    'Open the template
    Set objxl = CreateObject("excel.application")
    
    objxl.Workbooks.Open FileName:="MyFile Template-BLANK.xls"
    
    objxl.Visible = False 'True
    objxl.ScreenUpdating = False
    objxl.Sheets("VP Detail Data Review").Select
    objxl.Range("A3").Select

    'Populate it
    Dim db As DAO.Database
    Set db = CurrentDb
    Dim rst As DAO.Recordset
    Set rst = db.OpenRecordset("SELECT * FROM [qryFullData2-v2] WHERE [VP] = '" & strVPIn & "'", dbOpenForwardOnly)
    While Not rst.EOF
        objxl.ActiveCell.Value = rst!CID
        objxl.ActiveCell.offset(0, 1).Value = rst!ELID
        objxl.ActiveCell.offset(0, 2).Value = rst![Last Name]
        objxl.ActiveCell.offset(0, 3).Value = rst![First Name]
        objxl.ActiveCell.offset(0, 4).Value = rst!Title
        objxl.ActiveCell.offset(0, 5).Value = rst!Company
        objxl.ActiveCell.offset(0, 6).Value = rst![WorkerClassification]
        objxl.ActiveCell.offset(0, 7).Value = rst![DecisionTree]
        objxl.ActiveCell.offset(0, 8).Value = rst![Comments]
        objxl.ActiveCell.offset(0, 9).Value = rst![Business Unit]
        objxl.ActiveCell.offset(0, 10).Value = rst![Cost Center]
        
        objxl.ActiveCell.offset(0, 11).Value = rst![Manager CID]
        objxl.ActiveCell.offset(0, 12).Value = rst![Manager Last Name]
        objxl.ActiveCell.offset(0, 13).Value = rst![Manager First Name]
        objxl.ActiveCell.offset(0, 14).Value = rst![Sponsor First Name] & " " & rst![Sponsor Last Name]
        objxl.ActiveCell.offset(0, 15).Value = rst![Org Name]
        objxl.ActiveCell.offset(0, 16).Value = GetName(rst![VP])
        If IsNull(rst![Director]) Or rst![Director] = "" Then
            'Do nothing
        Else
            objxl.ActiveCell.offset(0, 17).Value = GetName(rst![Director]) 'StrConv(Replace(Left(rst![Director], InStr(rst![Director], "@") - 1), ".", " "), vbProperCase)
        End If
        objxl.ActiveCell.offset(0, 18).Value = rst![Start Date]
        objxl.ActiveCell.offset(0, 19).Value = rst![End Date]
        objxl.ActiveCell.offset(0, 20).Value = Int(rst![Days])
        objxl.ActiveCell.offset(0, 21).Value = Int(rst![Years])
        objxl.ActiveCell.offset(0, 22).Value = rst![Months]
        objxl.ActiveCell.offset(0, 23).Value = rst![Aging2]
        objxl.ActiveCell.offset(0, 24).Value = GetJobTitle(rst![VP])
        objxl.ActiveCell.offset(0, 25).Value = rst![VP]
        objxl.ActiveCell.offset(0, 26).Value = rst![Director]
        'objxl.ActiveCell.offset(0, 27).Value = rst![HRBP]
        
        objxl.ActiveCell.offset(1, 0).Select
        rst.MoveNext
    Wend
    rst.Close
    
    'Save it
        'Save the Spreadsheet
    
    objxl.ActiveWorkbook.SaveAs FileName:="MyFile" & Format(Now, "YYYYMMDD") & "\" & Format(Now, "YYYYMMDD") & "-" & strVPIn & " 3501 Report.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    objxl.ScreenUpdating = True
    objxl.Visible = True
    objxl.ActiveWorkbook.Close SaveChanges:=False
    'Close the Spreadsheet
    objxl.Workbooks.Close
    objxl.Quit
    Set objxl = Nothing
    Set rst = Nothing
    Set db = Nothing
    
    'Send it
    If blnSendEmail = True Then
        'Email the report
        
    End If
End Sub

[HansV]

This should be faster, but you'll have to edit it since I don't know what the function GetJobTitle does.
The '...' should be replaced with an expression that returns the job title for the VP.

Code: Select all

Sub OutputVPReport(strVPIn As String, blnSendEmail As Boolean)
    Dim objXL As Object
    Dim objWb As Object
    Dim objWs As Object
    Dim db As DAO.Database
    Dim rst As DAO.Recordset

    'Open the template
    Set objXL = CreateObject("excel.application")
    Set objWb = objXL.Workbooks.Open(FileName:="MyFile Template-BLANK.xls")
    Set objWs = objWb.Worksheets("VP Detail Data Review")

    'Populate it
    Set db = CurrentDb
    Set rst = db.OpenRecordset("SELECT CID, ELID, [Last Name], [First Name], Title, " & _
        "Company, WorkerClassification, DecisionTree, Comments, [Business Unit], " & _
        "[Cost Center], [Manager CID], [Manager First Name], [Manager Last Name], " & _
        "[Sponsor First Name] & ' ' & [Sponsor Last Name], [Org Name], " & _
        "StrConv(Replace(Left(VP,InStr(VP, '@')-1),'.',' '),3), " & _
        "IIf(Director & ''='','',StrConv(Replace(Left(Director,InStr(Director,'@')-1),'.',' '),3)), " & _
        "[Start Date], [End Date], Int(Days), Int(Years), Months, Aging2, " & _
        "'...', VP, Director FROM [qryFullData2-v2] WHERE VP = '" & strVPIn & "'", dbOpenForwardOnly)
    objWs.Range("A3").CopyFromRecordset rst
    rst.Close

    'Save it
    objWb.SaveAs FileName:="MyFile" & Format(Now, "YYYYMMDD") & "\" & Format(Now, "YYYYMMDD") & _
        "-" & strVPIn & " 3501 Report.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    objWb.Close SaveChanges:=True
    objXL.Quit
    Set objWs = Nothing
    Set objWb = Nothing
    Set objXL = Nothing
    Set rst = Nothing
    Set db = Nothing
End Sub

[Abraxus]

That worked very well, thank you! Now the one that used to take 42 minutes now takes 5 minutes. Considerable savings.

For some reason, however, the one for 40,864 only returns 3300 records but throws no error. I've even checked the SQL for accuracy. (Basically, it's the same SQL with no WHERE clause, a full dump of the data).

I'm still trying to figure that piece out.