Eksportowanie rekordów do arkusza kalkulacyjnego

Question

tylko zaznajomienie się trochę VBA (ten materiał nowego mi więc o wyrozumiałość!)

Od zapytania ContactDetails_SurveySoftOutcomes, staram się najpierw znaleźć listę wszystkich unikalnych wartości w W tym zapytaniu pole DeptName, a zatem rsGroup Dim przechowujące kwerendę zgrupowaną w polu DeptName.

Mam zamiar użyć tej zgrupowanej listy jako sposobu na cykliczne powtarzanie tego samego zapytania, ale przechodzenie przez każdy unikalny wpis jako filtr całego zestawu rekordów i eksportowanie każdego przefiltrowanego zestawu rekordów do własnego arkusza kalkulacyjnego Excel ... zobacz pętlę Do While Not.

Mój kod potknął się o część DoCmd.TransferSpreadsheet ... rsExport. Jestem trochę nowy w tym, ale domyślam się, że moje Dim nazwy rsExport dla zestawu rekordów nie jest akceptowane w tej metodzie ..?

Czy istnieje łatwa poprawka do kodu, który już rozpocząłem, czy też powinienem zastosować zupełnie inne podejście, aby to wszystko osiągnąć?

Kod:

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 

Poprawiono kod:

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

Masz rację, że parametr rsGroup jest źle, dostęp oczekuje nazwy tabeli lub kwerendy wybierającej.

Spróbuj kod:

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 

nadzieję, że działa

Answer 2

DoCmd.TransferSpreadsheet spodziewa się, że trzeci parametr być String (zmienna lub dosłowny) podając nazwę tabeli lub kwerendy. Tak więc, zamiast otwierania DAO.Recordset można utworzyć DAO.QueryDef o nazwie "forExportToExcel" z tym samym kodem SQL, a następnie użyć tej nazwy w wywołaniu TransferSpreadsheet.

Answer 3

spróbować tej nadziei to pomoże

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