Access + Vba + SQL - How to Export Multiple Queries into One Excel Workbook, But, Multiple Worksheet Using The Criteria from a Table

Export Access data into Excel workbook and split data into multiple sheets based on column value

Load a single recordset based on a query which gives you the unique pet types ...

SELECT DISTINCT p.Pet_Type
FROM Pets_data_table AS p;

Then walk that recordset, alter a saved query (qryExportMe) to SELECT the current Pet_Type, and export the query ...

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Dim strPath As String
Dim strSelectOneType As String
Dim strSelectPetTypes As String

' (change strPath back to what you need)
strPath = CurrentProject.Path & Chr(92) & "Pets_dataset_export_" & _
    Format(Date, "yyyy-mm-dd") & ".xlsx"
strSelectPetTypes = "SELECT DISTINCT p.Pet_Type" & vbCrLf & _
    "FROM Pets_data_table AS p;"

Set db = CurrentDb
Set rs = db.OpenRecordset(strSelectPetTypes, dbOpenSnapshot)
Do While Not rs.EOF
    strSelectOneType = "SELECT p.ID, p.Pet_Type, p.Pet_Owner" & vbCrLf & _
        "FROM Pets_data_table AS p" & vbCrLf & _
        "WHERE p.Pet_Type='" & rs!Pet_Type.Value & "';"
    Debug.Print strSelectOneType
    Set qdf = db.QueryDefs("qryExportMe")
    qdf.SQL = strSelectOneType
    qdf.Close
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
        "qryExportMe", strPath, True, rs!Pet_Type.Value
    rs.MoveNext
Loop
rs.Close

Note that code requires that the saved query, qryExportMe, exists. But its SQL property doesn't matter because you'll change it each time through the main Do While loop.

Export Excel sheet into Access Table & overwrite (or rename and create new)

In the end I have gone for a loop method adding the results. See the code below:

Dim db As DAO.Database, rs As DAO.Recordset, ws As Worksheet, i As Long, j As Long, arr, _
lrow As Long, lcol As Long, TblName As String, Info As Worksheet, StrPath As String, tbldf As DAO.TableDef

Set Info = Sheets("Info")
TblName = Info.Range("R6").Value
StrPath = Info.Range("R7").Value

Set ws = Sheets(TblName)
lrow = ws.Range("A" & Rows.Count).End(xlUp).Row
lcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
arr = ws.Range(ws.Cells(2, 1), ws.Cells(lrow, lcol)).Value
Set db = OpenDatabase(StrPath)

Set rs = db.OpenRecordset(TblName)

For i = 0 To rs.Fields.Count - 1
    If rs.Fields(i).Name <> ws.Cells(1, i + 1).Value Then
        MsgBox "There is a mis-match of the headers between the database and Excel sheet. You will need to ensure these are matched up " & _
        "before you continue", vbExclamation, "Mis-matched data"
        Exit Sub
    End If
Next i

On Error Resume Next
Set tbldf = db.TableDefs(TblName & "_ALL")
On Error GoTo 0
If tbldf Is Nothing Then
    db.Execute ("SELECT * INTO [" & TblName & "_ALL] FROM " & TblName)
End If

db.Execute "DELETE * FROM " & TblName

For i = 1 To UBound(arr, 1)
    rs.AddNew
    For j = 1 To UBound(arr, 2)
        rs.Fields(j - 1) = arr(i, j)
    Next j
    rs.Update
Next i

rs.Close
Set rs = Nothing
db.Close

Testing on a 68 column x 105K row table of data, it ran in just under 30 seconds on my machine which is plenty acceptable for me. This is not the full code I will use but is the code I needed from my question.

I managed this through a lot of help from Chris Maurer's answers/comments as well as searching. Thank you Chris for your assistance.

Related Topics