Slow Code Problem Exporting to Excel 2

[JeffAlton]

I have recently replace queries and lines of code like the following

DoCmd.OutputTo acQuery, "L001", "MicrosoftExcel(*.xls)", "\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\" & Format(Date, "MMM") & "\" & Format(Date, "YYMM") & "UPS-L001.XLS", False, ""

with this

Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim strQry As String
Dim qryDef As QueryDef
Dim FileName As String
Dim DestDir As String


Set db = CurrentDb

Set rst1 = db.OpenRecordset("SELECT * FROM tb1_UPS_ebill ORDER BY StoreNumber, StoreName;")

While (Not rst1.EOF)

strQry = "SELECT tb1_ups_ebill.StoreNumber, tb1_ups_ebill.StoreName," & _
" tb1_ups_ebill.InvoiceNumber, tb1_ups_ebill.BillDate, tb1_ups_ebill.InvoiceAmt," & _
" tb1_ups_ebill.TrackingNumber, tb1_ups_ebill.REF1 AS Department," & _
" tb1_ups_ebill.ReferenceNo1, tb1_ups_ebill.ReferenceNo2, tb1_ups_ebill.Internet_Id," & _
" tb1_ups_ebill.Quantity, tb1_ups_ebill.Billed_Weight, tb1_ups_ebill.Zone," & _
" tb1_ups_ebill.Transaction_Code, tb1_ups_ebill.Service_Description," & _
" tb1_ups_ebill.Bill_Option, tb1_ups_ebill.PickUp_Date, tb1_ups_ebill.Sender_Name," & _
" tb1_ups_ebill.Sender_Company_Name, tb1_ups_ebill.Sender_City, tb1_ups_ebill.Sender_State," & _
" tb1_ups_ebill.Receiver_Name, tb1_ups_ebill.Receiver_Company_Name," & _
" tb1_ups_ebill.Receiver_Street, tb1_ups_ebill.Receiver_City, tb1_ups_ebill.Receiver_State," & _
" tb1_ups_ebill.Receiver_ZipCode, tb1_ups_ebill.Receiver_Country," & _
" tb1_ups_ebill.Net_Charges, tb1_ups_ebill.Incentive FROM tb1_ups_ebill" & _
" WHERE [StoreName]='" & rst1.Fields(1) & "';"

Set qryDef = db.CreateQueryDef(rst1.Fields(1), strQry)
FileName = Format(Date, "YYMM") & "-" & rst1.Fields(0) & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, rst1.Fields(1), DestDir & FileName
db.QueryDefs.Delete (rst1.Fields(1))

rst1.MoveNext

Wend

Set rst1 = Nothing
Set db = Nothing

End Sub

The old way ran in less than a minute, the new way though more flexible takes more than 10 minutes. Is their a way to speed this up.

 

[flyover789]

If I well understand you, you want to output a list of all items in tbl1_ups_ebill for each storenumber. So the source of rst1 should be: SELECT t.StoreNumber, t.StoreName FROM tb1_ups_ebill t GROUP BY t.StoreNumber, t.StoreName ORDER BY t.StoreNumber, t.StoreName;

And instead of creating a new querydef for each StoreNumber you could simply apply a filter and output the filtered query:

assume you have a query like your strQuery, but without the WHERE clause. Let's name the query qryOutput

now you can use:

Dim db As DAO.Database
    Dim rst1 As DAO.Recordset
    Dim FileName As String
    Dim DestDir As String
    DestDir = "\\ntoscar\t-drive\Accounting\UPS\Store Billings\"
     
    Set db = CurrentDb
    
    Set rst1 = db.OpenRecordset([blue]"SELECT t.StoreNumber, t.StoreName FROM  tb1_ups_ebill t GROUP BY t.StoreNumber, t.StoreName ORDER BY t.StoreNumber, t.StoreName;[/blue]")
    
    While (Not rst1.EOF)

[blue]
        docmd.openquery "qryOutput"
        docmd.applyfilter "StoreName = '" & rst1.Fields(1) & "'"

        FileName = Format(Date, "YYMM") & "-" & rst1.Fields(0) & ".xls"

        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, qryOutput, DestDir & FileName
[/blue]        
        rst1.MoveNext
         
    Wend
     
    Set rst1 = Nothing
    Set db = Nothing

hth,
fly

[blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue]

Martin Serra Jr.

http://www.mserrasystems.com

[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[flyover789]

I'm sorry, but I found a typo, that affects the functionality of the code, that I've posted

please replace the line
docmd.applyfilter "StoreName = '" & rst1.Fields(1) & "'"
by
docmd.applyfilter [red],[/red] "StoreName = '" & rst1.Fields(1) & "'"

[blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue]

Martin Serra Jr.

http://www.mserrasystems.com

[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[JeffAlton]

I am getting an error: the action or method requires a table name argument

And the debugger goes to this Line: DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, qryOutput, DestDir & FileName

I have created the query.

 

[PHV]

Replace this:
qryOutput
By this:
"qryOutput"

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[flyover789]

perhaps:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, [b][red]"qryOutput"[/red][/b], DestDir & FileName

Hope that helps!
fly

[b][blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue][/b]

Martin Serra Jr.
[URL unfurl="true"]www.mserrasystems.com[/URL]
[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[flyover789]

PHV, you are the fastest poster!!

[blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue]

Martin Serra Jr.

http://www.mserrasystems.com

[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[JeffAlton]

Runs alot faster but all of the spreadsheets contain all of the records from the table.

 

[flyover789]

so it seems, that the filter isn't working correctly ..
can you please post your entire code?
Many thanks in advance,
bye,
Martin

[blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue]

Martin Serra Jr.

http://www.mserrasystems.com

[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[JeffAlton]

The filter seems to be working. I can see the query as it loops. Before I added the last line to close the query their were 65 records filtered in the query. I tried to export from the menu bar and still got 2659 records in my spreadsheet.


Sub ExportData2()
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim FileName As String
Dim DestDir As String

Const ATTR_DIRECTORY = 16

'Checks if Current Year Directory Exists
If Dir("\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\", ATTR_DIRECTORY) <> "" Then
' MsgBox ("The directory exist")
Else
'If Current Year Directory Doesn't Exist Then It Is Created
' MsgBox ("The directory " & Format(Date, "YYYY") & " does not exist" & vbCrLf & "Directory will be Created")
MkDir "\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\"
End If
'Checks if Current Month Directory Exists
If Dir("\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\" & Format(Date, "MMM") & "\", ATTR_DIRECTORY) <> "" Then
' MsgBox ("The directory exist")
Else
'If Current Month Directory Doesn't Exist Then It Is Created
' MsgBox ("The directory " & UCase(Format(Date, "MMM")) & " does not exist" & vbCrLf & "Directory will be Created")
MkDir "\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\" & UCase(Format(Date, "MMM")) & "\"
End If

DestDir = "\\ntoscar\t-drive\Accounting\UPS\Store Billings\" & Format(Date, "YYYY") & "\" & (Format(Date, "MMM")) & "\"

Set db = CurrentDb

Set rst1 = db.OpenRecordset("SELECT t.StoreNumber, t.StoreName FROM tb1_ups_ebill t GROUP BY t.StoreNumber, t.StoreName ORDER BY t.StoreNumber, t.StoreName;")

While (Not rst1.EOF)


DoCmd.OpenQuery "qryOutput"
DoCmd.ApplyFilter , "StoreName = '" & rst1.Fields(1) & "'"
FileName = Format(Date, "YYMM") & "-" & rst1.Fields(0) & ".xls"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "qryOutput", DestDir & FileName

rst1.MoveNext

Wend

Set rst1 = Nothing
Set db = Nothing
DoCmd.Close acQuery, "qryOutput", acSaveNo
End Sub

 

[flyover789]

instead of

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "qryOutput", DestDir & FileName

try

DoCmd.OutputTo acOutputQuery, "qryOutput", acSpreadsheetTypeExcel97, DestDir & Filename

hth,
fly

[blue]Typos, that don't affect the functionality of code, will not be corrected.[/blue]

Martin Serra Jr.

http://www.mserrasystems.com

[blue]Shared Database_Systems and _Applications across all Business_Areas[/blue]

 

[JeffAlton]

Thank You Very Much.