get data to Excel, faster

[cargobay69]

I wrote a very functional procedure that takes an ADO recordset and writes it to an Excel file (reference: Microsoft Excel 10.0). It works fine, but it is slow. It takes about a minute to write a file 500 records long with 22 fields on my 800 MHz machine. I do not have the option to use Access's TransferSpreadsheet method as the data is being extracted from a SQL server. All I want is a faster method, any ideas?

FYI, my code:

Public Function ExportExcel(rsRecordset As ADODB.Recordset, sFileName As String, Optional sTabName As String, Optional sIncludeFieldNames As Boolean = True) As Boolean
Dim xlApp As Excel.Application
Dim bContinue As Boolean
Dim bNew As Boolean
Dim sWorksheet As String
Dim lTabNameLen As Long
Dim xlWorksheet As Excel.Workbook
Dim lTemp As Long
Dim bWorksheetFound As Boolean
Dim lColumn As Long
Dim lRow As Long

  Set xlApp = New Excel.Application
  'verify file
  xlApp.Visible = True
  lTabNameLen = Len(sTabName)
  If IsFile(sFileName) Then
    xlApp.Workbooks.Open (sFileName)
    If CBool(lTabNameLen) Then
      For lTemp = 1 To xlApp.Worksheets.Count
        If xlApp.Worksheets(lTemp).Name = sTabName Then
          xlApp.Worksheets("sTabName").Select
          bWorksheetFound = True
          Exit For
        End If
      Next
      If Not bWorksheetFound Then
        xlApp.Worksheets.Add
        If lTabNameLen > 31 Then
          sWorksheet = Left(sTabName, 31)
        Else
          sWorksheet = sTabName
        End If
        xlApp.ActiveSheet.Name = sWorksheet
      End If
    Else
      xlApp.Worksheets.Add
      sWorksheet = xlApp.ActiveSheet.Name
    End If
      
  Else
    If Not IsFolder(GetParentDirectory(sFileName)) Then
      If Not CreatePath(GetParentDirectory(sFileName)) Then
        MsgBox "ExportExcel procedure failed" & vbNewLine & vbNewLine & "Unable to create file in specified directory path:" & vbNewLine & sFileName, vbCritical
        Exit Function
      End If
    End If
    xlApp.Workbooks.Add
    xlApp.ActiveWorkbook.SaveAs sFileName
    If CBool(lTabNameLen) Then
      If lTabNameLen > 31 Then
        sWorksheet = Left(sTabName, 31)
      Else
        sWorksheet = sTabName
      End If
      xlApp.Worksheets(1).Name = sWorksheet
    Else
      sWorksheet = xlApp.Worksheets(1).Name
    End If
  End If
  xlApp.Worksheets(sWorksheet).Select
  lColumn = Asc("A")
  lRow = 1
  For lColumn = 0 To rsRecordset.Fields.Count - 1
    xlApp.Cells(lRow, lColumn + 1).Value = rsRecordset.Fields(lColumn).Name
  Next
  Do Until rsRecordset.EOF
    lRow = lRow + 1
    For lColumn = 0 To rsRecordset.Fields.Count - 1
      xlApp.Cells(lRow, lColumn + 1).Value = rsRecordset.Fields(lColumn).Value
    Next
    rsRecordset.MoveNext
  Loop
End Function

Thanks,