Esportazione Recordset in foglio di calcolo

Question

Proprio alle prese qualche VBA (di nuovo per me questa roba modo da portare con noi!)

da Query ContactDetails_SurveySoftOutcomes, sto cercando di trovare prima un elenco di tutti i valori unici il campo DeptName in quella query, da cui la dimensione rsGroup che memorizza una query raggruppata nel campo-NomeDistribuzione .

Ho quindi intenzione di utilizzare questo elenco raggruppato come modo di scorrere nuovamente la stessa query, ma passando attraverso ogni voce univoca come filtro sull'intero recordset ed esportare ogni recordset filtrato sul proprio foglio di calcolo Excel ... vedere il ciclo Do While Not.

Il mio codice sta scattando sulla parte DoCmd.TransferSpreadsheet ... rsExport. Sono un po 'nuovo a questo, ma suppongo che il mio nome Dim rsExport per il recordset non sia accettato in questo metodo ..?

C'è una soluzione facile al codice che ho già avviato o dovrei usare un approccio completamente diverso per ottenere tutto questo?

Codice:

Public Sub ExportSoftOutcomes() 

Dim rsGroup As DAO.Recordset 
Dim Dept As String 
Dim myPath As String 

myPath = "C:\MyFolder\" 

Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _ 
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset) 

Do While Not rsGroup.EOF 

    Dept = rsGroup!DeptName 

    Dim rsExport As DAO.Recordset 
    Set rsExport = CurrentDb.OpenRecordset("SELECT * FROM ContactDetails_SurveySoftOutcomes " _ 
    & "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))", dbOpenDynaset) 

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, rsExport, myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True 

    rsGroup.MoveNext 

Loop 

End Sub 

Fisso Codice:

Public Sub ExportSoftOutcomes() 

Dim rsGroup As DAO.Recordset 
Dim Dept As String 
Dim myPath As String 

myPath = "C:\MyFolder\" 

Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _ 
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset) 

Do While Not rsGroup.EOF 
    Dept = rsGroup!DeptName 

    Dim rsExportSQL As String 
    rsExportSQL = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _ 
    & "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))" 

    Dim rsExport As DAO.QueryDef 
    Set rsExport = CurrentDb.CreateQueryDef("myExportQueryDef", rsExportSQL) 

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True 

    CurrentDb.QueryDefs.Delete rsExport.Name 

    rsGroup.MoveNext 
Loop 

End Sub 

Answer 1

Hai ragione che il parametro rsGroup è sbagliato, Accesso si aspetta un nome di tabella o query di selezione.

provare questo codice:

strExport = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _ 
& "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))" 

Set qdfNew = CurrentDb.CreateQueryDef("myExportQueryDef", strExport) 

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True 

CurrentDb.QueryDefs.Delete qdfNew.Name 'cleanup 

Speranza che funziona

Answer 2

DoCmd.TransferSpreadsheet aspetta il suo terzo parametro ad essere una stringa (variabile o letterale) specificando il nome di una tabella o query. Pertanto, anziché aprire DAO.Recordset, è possibile creare un valore DAO.QueryDef denominato "forExportToExcel" con lo stesso codice SQL, quindi utilizzare tale nome nella chiamata TransferSpreadsheet.

Answer 3

provare questa speranza che questo vi aiuterà

Function Export2XLS(sQuery As String) 
    Dim oExcel   As Object 
    Dim oExcelWrkBk  As Object 
    Dim oExcelWrSht  As Object 
    Dim bExcelOpened As Boolean 
    Dim db    As DAO.Database 
    Dim rs    As DAO.Recordset 
    Dim iCols   As Integer 
    Const xlCenter = -4108 

    'Start Excel 
    On Error Resume Next 
    Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel 

    If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one 
     Err.Clear 
     On Error GoTo Error_Handler 
     Set oExcel = CreateObject("excel.application") 
     bExcelOpened = False 
    Else 'Excel was already running 
     bExcelOpened = True 
    End If 
    On Error GoTo Error_Handler 
    oExcel.ScreenUpdating = False 
    oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation 
    Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook 
    Set oExcelWrSht = oExcelWrkBk.Sheets(1) 

    'Open our SQL Statement, Table, Query 
    Set db = CurrentDb 
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot) 
    With rs 
     If .RecordCount <> 0 Then 
      'Build our Header 
      For iCols = 0 To rs.Fields.Count - 1 
       oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name 
      Next 
      With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ 
            oExcelWrSht.Cells(1, rs.Fields.Count)) 
       .Font.Bold = True 
       .Font.ColorIndex = 2 
       .Interior.ColorIndex = 1 
       .HorizontalAlignment = xlCenter 
      End With 
      oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ 
           oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit 'Resize our Columns based on the headings 
      'Copy the data from our query into Excel 
      oExcelWrSht.Range("A2").CopyFromRecordset rs 
      oExcelWrSht.Range("A1").Select 'Return to the top of the page 
     Else 
      MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" 
      GoTo Error_Handler_Exit 
     End If 
    End With 

    ' oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook 

    ' 'Close excel if is wasn't originally running 
    ' If bExcelOpened = False Then 
    '  oExcel.Quit 
    ' End If 

Error_Handler_Exit: 
    On Error Resume Next 
    oExcel.Visible = True 'Make excel visible to the user 
    rs.Close 
    Set rs = Nothing 
    Set db = Nothing 
    Set oExcelWrSht = Nothing 
    Set oExcelWrkBk = Nothing 
    oExcel.ScreenUpdating = True 
    Set oExcel = Nothing 
    Exit Function 

Error_Handler: 
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ 
      "Error Number: " & Err.Number & vbCrLf & _ 
      "Error Source: Export2XLS" & vbCrLf & _ 
      "Error Description: " & Err.Description _ 
      , vbOKOnly + vbCritical, "An Error has Occured!" 
    Resume Error_Handler_Exit 
End Function