Exporting multiple Access queries to multiple excel workshts

coline · Oct 3, 2003

Hi, I would like to export several queries into one Excel file, with each query on a separate worksheet. I've gotten a bit of advice from the Excel board about doing this from Excel as opposed to from Access. Ideally, though, I would like to run this from my Access DB. Any suggestions on this would be appreciated. Currently my system works as follows:

1. From a form, the user selects the record ID she would like to query.
2. When the user clicks "go", the query is run, Excel opens, and the query is placed in the Excel file that is created in the same location that the Access DB exists on the user's computer (this location is variable, depending on who is using the DB.)

I have this working for 1 query, but ideally, I would like to run multiple queries at once, and then put each of these in a different worksheet. The code I have so far is below:

Private Sub runquery(qry As String)
Dim FileName As String
Dim FilePath As String
Dim CurrDate As String

'The purpose of this query is to open the selected query, and then to export
'these data to an excel file.

'qry is the passed argument, specifiying the name of the particular query I want to export.
DoCmd.OpenQuery qry, acViewNormal, acEdit

'This specifies the name and location of the created Excel file.
FileName = "Query " & CurrDate & Me!UNQID
FilePath = ObtainDir(Application.CurrentDb.name) & FileName & ".xls"

'Exports data to the Excel file.
DoCmd.OutputTo acOutputQuery, , acFormatXLS, FilePath, -1

coline · Oct 7, 2003

Hi, I've made some progress on this question. I can get data from multiple tables into multiple Excel worksheets, but I can't do this with a parameterized query. If you are interested in this topic, please see the code below; I'd appreciate your help! I've inserted comments where I'm still running into the following snags:

1. I can open up a parameterized query, but only when the parameter is a number (text hasn't worked yet).
2. I haven't figured out how to dynamically set up column headings in the exported files; it currently exports without headings.

Dim appExcel As New Excel.Application
Dim wkbExcel As Excel.Workbook
Dim wkshtExcel As Excel.Worksheet
Dim rngExcel As Excel.Range
Dim rs As New ADODB.Recordset
Dim catCurr As New ADOX.Catalog
Dim cmdcurr As New ADODB.Command

'The code below comes out of "MS Access 2000 Power Programming: the authoritative solution" p. 162 - how to open up a recordset off a parameterized query.

catCurr.ActiveConnection = CurrentProject.Connection

Set cmdcurr = catCurr.Procedures("REVIEW ARQni Personnel SW allocations").Command

'The code below that defines the parameter does not work in the current form, although it does work to run it off a numeric field. The example in the book uses a date.

cmdcurr.Parameters("[Enter UNQID]") = "5L07"

rs.Open cmdcurr, , adOpenKeyset, adLockReadOnly, adCmdStoredProc

'We've gotten the code below to run successfully off a table, but it won't work with the query!!

Set appExcel = New Excel.Application
appExcel.Visible = True
Set wkbExcel = appExcel.Workbooks.add

For intNumber = 0 To 2
'rs.Open "Select * FROM [tbl strt]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

Set wkshtExcel = wkbExcel.Worksheets.add
rs.MoveLast
rs.MoveFirst

'We haven't yet figured out a dynamic way to apply column headings. The example in the book does this in a static way.

Set rngExcel = wkshtExcel.Range(wkshtExcel.Cells(2, 1), wkshtExcel.Cells(rs.RecordCount + 2, rs.Fields.count - 1))
rngExcel.CopyFromRecordset cmdcurr

wkshtExcel.Columns.AutoFit
wkshtExcel.Rows.AutoFit
rs.Close
Next
'Exports data to the Excel file.
'DoCmd.OutputTo acOutputQuery , , acFormatXLS, FilePath, -1

End Sub

bat17 · Oct 8, 2003

Here is a snippet of code from one of my projects, rather than using a paramatised query I create the SQL and add the criteria on the fly. You should be able to use the SQL from your existing query and modify it easily enough. (When I am setting up something like this I step through the code to the point where the SQL is constructed then print it to the Debug Window and then copy and paste the resulting SQL into a normal query to make sure I have created what I intended.)
Once the SQL statement is made I then make the recordset and loop through it to put the Field names into Excel as column headers before dumping the data in.
This is written for A97 but will probably work the same for 2000.

Code:

'Month
strSql = "SELECT qryComplaintBase.AreaCode, Sum(qryComplaintBase.[Sqm Under Complaint]) AS [SumOfSqm Under Complaint], Sum(qryComplaintBase.[Complaint Total Cost]) AS [SumOfComplaint Total Cost] "
strSql = strSql & "FROM qryComplaintBase "
strSql = strSql & "WHERE (((qryComplaintBase.monthSer) <= " & dblEndDateSer & "))"
strSql = strSql & "GROUP BY qryComplaintBase.AreaCode;"
Set rst = dbs.OpenRecordset(strSql, dbOpenForwardOnly)
j = lngStartColTypeMonth
For Each fld In rst.Fields
   .Cells(5, j) = fld.Name
j = j + 1
Next fld
'add records to XL
.Cells(6, lngStartColTypeMonth).CopyFromRecordset rst

Hope that this makes some sort of sense!!
Peter

Philem · Oct 9, 2003

Hullo. Here is a code part for a project that works as you describe, with the exception of putting the results on different sheets. Not hard at all. The code below performs the same action on different workbooks, though.

Code:

Function sMassivePODetailPopulate()

Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Dim qd As QueryDef
Dim rs As Recordset
Dim intLastCol As Integer
Dim boolXL As Boolean

Dim strShtName As String
Dim intFW As Integer
Dim strSheets(4) As String
Dim x As Integer
Dim strWkbName As String

Dim strTemp As String
Dim lngCount As Long
Dim strRecTo(1, 0) As String
Dim strRecCC(1, 2) As String
Dim varAttach(4) As Variant
Dim cGW As GW

Dim ErrNum As Long
Dim ErrDescr As String

On Error GoTo Err_Handler

strSheets(1) = "floral"
strSheets(2) = "homedec"
strSheets(3) = "craftnotion"
strSheets(4) = "seasonal"

x = 1

'Err.Raise 65535, , "A test error message."
Set db = CurrentDb
Set qd = db.QueryDefs("qryCurrentFW")
Set rs = qd.OpenRecordset
    With rs
        intFW = !FW.Value
    End With
Set db = Nothing
Set qd = Nothing
Set rs = Nothing

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'intFW = 34
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Screen.MousePointer = 11

If fIsAppRunning("Excel") Then
    Set objXL = GetObject(, "Excel.Application")
    boolXL = False
Else
    Set objXL = CreateObject("Excel.application")
    boolXL = True
End If

Do Until x = 5     '<<--UPDATE FOR REAL RUN (should be 5)

With objXL
    .Workbooks.Open ("Q:\Inventory Management\PO Tracking\DataFiles\bigcontlist.xls")
    .Workbooks.Open ("Q:\Inventory Management\PO Tracking\DataFiles\OrderStat Master.xls")
    .Workbooks.Open ("Q:\Inventory Management\PO Tracking\DataFiles\Vendors.xls")
    .Workbooks.Open ("Q:\Inventory Management\PO Tracking\DataFiles\vslinfo.xls")
End With

strWkbName = "c:\my documents\current po track sandbox\fw" & intFW & " " & strSheets(x) & ".xls"
varAttach(x) = strWkbName
  Set db = CurrentDb
  Set objXL = Excel.Application
  objXL.Visible = True
  objXL.WindowState = xlMinimized
  
    
  With objXL
    .Visible = True
    .WindowState = xlMinimized
    Set objWkb = .Workbooks.Open(strWkbName)
    On Error Resume Next
    
  Dim ws As Worksheet
  
  For Each ws In Worksheets
  ws.Activate
  strShtName = .ActiveSheet.Name
  Set qd = db.QueryDefs("qryMassive")
  qd.Parameters("Unit?") = strShtName
  Set rs = qd.OpenRecordset
    Set objSht = objWkb.Worksheets(strShtName)
    Err.Clear
    On Error GoTo 0
    intLastCol = objSht.UsedRange.Columns.Count
    With objSht
      .Range("a16").CopyFromRecordset rs
    End With
    
    Set qd = db.QueryDefs("ExcelZRQ1Cost")
        qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("B8").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
        
    Set qd = db.QueryDefs("ExcelZRQ1Units")
        qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("G8").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
    
    Set qd = db.QueryDefs("ExcelDCOHDollars")
        qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("B7").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
    
    Set qd = db.QueryDefs("ExcelDCOHQty")
        qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("G7").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
    
    Set qd = db.QueryDefs("ExcelStoreOHDollars")
       qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("B11").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
    
    Set qd = db.QueryDefs("ExcelStoreOHQty")
        qd.Parameters("Unit?") = strShtName
        Set rs = qd.OpenRecordset
        Err.Clear
        On Error GoTo 0
            With objSht
                .Range("G11").CopyFromRecordset rs
            End With
    Set rs = Nothing
    Set qd = Nothing
    
    '''''''''''''''''''''''''''''''''''''''''''''''
    'Calls to formatting subs
    Call sAdFormat
    Call sArticleFormat
    Call sActivateCopy
    '''''''''''''''''''''''''''''''''''''''''''''''
  
  
  Next ws
  End With
objXL.DisplayAlerts = False
  objXL.Workbooks("fw" & intFW & " " & strSheets(x) & ".xls").Close SaveChanges:=True
'objWkb.Close savechanges:=True
x = x + 1
Set ws = Nothing
Loop
  
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'DO NOT MODIFY THE BELOW LINE
'Call sMassiveFabricPODetailPopulate(intFW)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set db = CurrentDb
Set qd = db.QueryDefs("qryCurrentFW")
Set rs = qd.OpenRecordset
    With rs
        intFW = !FW.Value
        .Edit
        !Used = -1
        .Update
    End With
Set db = Nothing
Set qd = Nothing
Set rs = Nothing

With objXL
    .Workbooks.Close
End With
  

fCloseApp ("XLMAIN")

  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set db = Nothing
Screen.MousePointer = 1

Set cGW = New GW
    With cGW
        .Login
        .BodyText = "The PO Tracking process completed successfully at " & Now
        .Subject = "Successful PO Tracking run"
        .RecTo = strRecTo
        .RecCc = strRecCC
        .FileAttachments = varAttach
        .FromText = "Access Mailer Daemon"
        strTemp = .CreateMessage
        .ResolveRecipients strTemp
        If IsArray(.NonResolved) Then MsgBox "Some unresolved recipients."
        .SendMessage strTemp
        .DeleteMessage strTemp, True
    End With
Set cGW = Nothing
sSleep (5000)

Exit_Here:
    fTerminateWin (0)
    fTerminateWin (1)
    Exit Function

Err_Handler:
    ErrNum = Err.Number
    ErrDescr = Err.Description
    
    Set cGW = New GW
    With cGW
        .Login
        .BodyText = "The PO tracking process encountered error " & ErrNum & ": " & ErrDescr & ". This happened while processing the " & strShtName & _
        " sheet in the " & strWkbName & " workbook."
        .Subject = "PO Tracking ERROR!"
        .RecTo = strRecTo
        .RecCc = strRecCC
        .FromText = "Access Mailer Daemon"
        .Priority = "High"
        strTemp = .CreateMessage
        .ResolveRecipients strTemp
        If IsArray(.NonResolved) Then MsgBox "Some unresolved recipients."
        .SendMessage strTemp
        .DeleteMessage strTemp, True
    End With
    Set cGW = Nothing
    sSleep (5000)
    Resume Exit_Here

End Function

Feel free to modifiy this to your taste. NOTE: The e-mail code refered to is for GroupWise, handled through a seperate module.

Have fun, and HTH!

P

Exporting multiple Access queries to multiple excel workshts

coline

New Member

Excel Facts

coline

New Member

bat17

Well-known Member

Philem

Active Member

Similar threads

Forum statistics

Share this page

Exporting multiple Access queries to multiple excel workshts

coline

New Member

Excel Facts

coline

New Member

bat17

Well-known Member

Philem

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock