İhracat Recordset E-Tabloya

Question

Sadece ben her şeyden önce benzersiz değerler listesi içinde bulmaya çalışıyorum bazı VBA (bu sey yeni bana çok sabırlı!) Sorgusu itibaren

ContactDetails_SurveySoftOutcomes kulpları almak bu sorgu DeptName alan, dolayısıyla rsGroup Çin DeptName sahada gruplanmış sorgu depolanması.

Bu gruplandırılmış listeyi tekrar aynı sorguda dolaşmanın bir yolu olarak kullanacağım, ancak tüm kayıt kümesinde bir süzgeç olarak her benzersiz girdiden geçerek filtrelenmiş her bir kayıt kümesini kendi Excel elektronik tablosuna aktarıyorum ... Do While Not döngüsüne bakın.

Kodum en DoCmd.TransferSpreadsheet ... rsExport kısmına kadar açma. Bu konuda biraz yeniyim, ama sanırım bu kayıtta kayıt seti için rsExport Dim ismim kabul edilmedi ..?

Zaten başladım yoksa tüm Bunu başarmak için tamamen farklı bir yaklaşım kullanarak gereken kod kolay bir düzeltme var mı?

Kod: Kod Sabit

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 

:

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

Sen sağ rsGroup parametre yanlış olduğunu, erişim bir tablo adı veya seçme sorgusu bekliyor.

Answer 2

DoCmd.TransferSpreadsheet üçüncü parametre bir tablo veya sorgunun adını belirterek (değişken veya değişmez) bir dize olmasını bekler çalışır

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 

Hope:

bu kodu deneyin. Yani, bir DAO.Recordset açmak yerine, aynı SQL koduyla "forExportToExcel" gibi bir ad olarak adlandırılan bir DAO.QueryDef oluşturabilir, daha sonra TransferSpreadsheet çağrısında bu adı kullanabilirsiniz. o adı bu sanki

Answer 3

bu daha sonra O **, Microsoft Access veritabanı alt yapısı nesne ** bulamadık söylüyor

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