Ken Snell's Multiple sheet export

[icq_giggles]

I've tried to use Ken's code, it worked fine then suddenly stopped. I've
been tweaking it so there could be compound problems by now.

Here's my adaptation, but (while it used to run) now I am getting a 3022
error - primary key type violation, not sure why or how - the break happens
at the qdf.Name = strDes
line. I'm sure it's something stupid I 've done or missed but been looking
at it too long to see.

ANY Help is appreicated - THANKS!

Public Sub PrelimExport()
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstDes As DAO.Recordset
Dim strSQL As String, strTemp As String, strDes As String
Dim OBV As String
Dim ds As String


Const strFileName As String = "ADPML_Vehicle"

Const strQName As String = "zExportQuery"

Set dbs = CurrentDb
OBV = [Forms]![frmBOMUpload]![txtOBV].Value

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"qryWhereUsed", "H:\New ADPML data\TEST\Prelim_ADPML_Vehicle_" & OBV &
".xls"


' Create temporary query that will be used for exporting data;
'DoCmd.DeleteObject acQuery, "zExportQuery"
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName


' Get list of Designation values

strSQL = "SELECT DISTINCT tblBOM.Designation" & _
" FROM tblBOM" & _
" WHERE (((tblBOM.Vehicle)like'*" & OBV & "*'));"
Set rstDes = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

' Now loop through list of Designation values and create a query for each
Designation
' so that the data can be exported
If rstDes.EOF = False And rstDes.BOF = False Then
rstDes.MoveFirst
Do While rstDes.EOF = False
strDes = DLookup("[Designation]", "tblBOM", _
"[designation] = " & "'" & rstDes!designation.Value & "'")
strSQL = "SELECT * FROM qryADPML WHERE " & _
"[Designation] = '" & strDes & "';"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = strDes
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
ds = rstDes!designation.Value
If ds = "A Assembly" Or ds = "B Assembly" Or ds = "Vehicle
Assembly" Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
strTemp, "H:\New ADPML data\TEST\Prelim_ADPML_Vehicle_" &
OBV & ".xls"
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
strTemp, "H:\New ADPML data\TEST\Prelim_ADPML_Kits_" & OBV
& ".xls"
End If
rstDes.MoveNext
Loop
End If

rstDes.Close
Set rstDes = Nothing

dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing
Call Format


End Sub

 

[Steve Sanford]

When I start having problems, I add "Debug.Pring strSQL" statements after any
line where I create a SQL string:

strSQL = "SELECT field1 FROM MyTable WHERE 1=0 "
Debug.Pring strSQL

Then I set a breakpoint and single step thru the code, checking the
immediate window after a debug pring line. I can copy the string from the
immediate windlw, switch to the query designer,create a new query, switch to
SQL view and paste in the string. I can run the query and check that the
results are what I expect.

Looking at your code, I saw three things I would correct.

1) In the following line, you are missing spaces in the WHERE clause:

strSQL = "SELECT DISTINCT tblBOM.Designation" & _
" FROM tblBOM" & _
" WHERE (((tblBOM.Vehicle)like'*" & OBV & "*'));"

There should be a space before and after the word LIKE.

2) If you set the variable qdf to nothing, you are destroying the pointer to
the variable. It (the variable) doesn't exist any more. So the second time
you loop thru the code, there is no variable, so you can't assign it a name.

qdf.Name = strDes
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing '<<<=======

3) This is a small item.

You didn't "open" the dbs, so you shouldn't close it.
You *did* create it ("Set dbs = CurrentDb "),
so you should destroy it ("Set dbs = Nothing ")

dbs.Close <== not needed!
Set dbs = Nothing

HTH
--
Steve S
--------------------------------
"Veni, Vidi, Velcro"
(I came; I saw; I stuck around.)

I've tried to use Ken's code, it worked fine then suddenly stopped. I've
been tweaking it so there could be compound problems by now.

Here's my adaptation, but (while it used to run) now I am getting a 3022
error - primary key type violation, not sure why or how - the break happens
at the qdf.Name = strDes
line. I'm sure it's something stupid I 've done or missed but been looking
at it too long to see.

ANY Help is appreicated - THANKS!

Public Sub PrelimExport()
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstDes As DAO.Recordset
Dim strSQL As String, strTemp As String, strDes As String
Dim OBV As String
Dim ds As String


Const strFileName As String = "ADPML_Vehicle"

Const strQName As String = "zExportQuery"

Set dbs = CurrentDb
OBV = [Forms]![frmBOMUpload]![txtOBV].Value

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"qryWhereUsed", "H:\New ADPML data\TEST\Prelim_ADPML_Vehicle_" & OBV &
".xls"


' Create temporary query that will be used for exporting data;
'DoCmd.DeleteObject acQuery, "zExportQuery"
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName


' Get list of Designation values

strSQL = "SELECT DISTINCT tblBOM.Designation" & _
" FROM tblBOM" & _
" WHERE (((tblBOM.Vehicle)like'*" & OBV & "*'));"
Set rstDes = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

' Now loop through list of Designation values and create a query for each
Designation
' so that the data can be exported
If rstDes.EOF = False And rstDes.BOF = False Then
rstDes.MoveFirst
Do While rstDes.EOF = False
strDes = DLookup("[Designation]", "tblBOM", _
"[designation] = " & "'" & rstDes!designation.Value & "'")
strSQL = "SELECT * FROM qryADPML WHERE " & _
"[Designation] = '" & strDes & "';"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = strDes
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
ds = rstDes!designation.Value
If ds = "A Assembly" Or ds = "B Assembly" Or ds = "Vehicle
Assembly" Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
strTemp, "H:\New ADPML data\TEST\Prelim_ADPML_Vehicle_" &
OBV & ".xls"
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
strTemp, "H:\New ADPML data\TEST\Prelim_ADPML_Kits_" & OBV
& ".xls"
End If
rstDes.MoveNext
Loop
End If

rstDes.Close
Set rstDes = Nothing

dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing
Call Format


End Sub

 

[Ken Snell MVP]

See my reply in m.p.access newsgroup.