Codebeispiel - Export nach Excel von Formular mit CopyFromRecordset-Methode

[ios707]

Hallo zusammen,

so was habe ich hier vor ein paar Tagen mal gesucht, es aber nie wirklich ausführlich beschrieben gesehen. Also dachte ich mir, stelle ich es ein ... nach so etwas ähnlichem haben schon viele Leute hier gefragt.

Der Code ist für einen Button gedacht, der auf einem Hauptformular liegt. Das Hauptformular enthält ein Unterformular, in dem die Daten angezeigt werden. Der Code muss nur an einer Stelle angepasst werden, nämlich der Name des Steuerelements, das das Unterformular enthält.

Ich hoffe es hilft dem einen oder anderen ...

Code:

Private Sub cmdXLSExport_Click()
' Export aller Daten des Unterformulars nach Excel mit CopyFromRecordset-Methode
Dim iCols As Integer
Dim rs As Recordset
Dim ws As Object
Dim wb As Object
Dim ExcelApp As Object

    ' Neue Excel Datei, Arbeitsmappe und Worksheet erstellen
    Set ExcelApp = CreateObject("Excel.Application")
    Set wb = ExcelApp.Workbooks.Add
    Set ws = ExcelApp.Worksheets.Add
    ' Recordset des Unterformulars kopieren,
    ' hier muss der Name des Steuerelements, das das Unterformular enthält, angepasst werden
    '---------------
    Set rs = Me!NameSteuerelement.Form.RecordsetClone
    '---------------
    ' Nur was machen, wenn Daten vorhanden sind
    If Not rs.EOF Then
    	rs.MoveFirst
        ' Daten nach Excel kopieren
        For iCols = 0 To rs.Fields.Count - 1
            ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
        Next
        ws.Range(ws.Cells(1, 1), _
            ws.Cells(1, rs.Fields.Count)).Font.Bold = True
        ws.Range("A2").CopyFromRecordset rs
    End If
    ' Excel sichtbar machen
    ExcelApp.Visible = True
    
    ' Alles resetten
    Set ws = Nothing
    Set wb = Nothing
    Set ExcelApp = Nothing
End Sub

[ios707]

Ich hatte wohl nicht gründlich genug gesucht, Josef hat nämlich auch schon mal was ähnliches geschrieben, nur noch besser

http://www.ms-office-forum.net/forum...2&postcount=14

[ios707]

Hier ein kleines Update. Die Spaltenbreite in Excel wird jetzt auch noch automatisch angepasst und die Handhabung ist viel leichter nach Anlehnung an die Ideen von Josef.

Der Code kommt nun bspw. in ein Modul:

Code:

Public Sub XLSExportRS(rs As Recordset)
' Export aller Daten des Unterformulars nach Excel mit CopyFromRecordset-Methode
' David Niegisch, 10.02.2010
Dim iCols As Integer
Dim ws As Object
Dim wb As Object
Dim ExcelApp As Object
    ' Neue Excel Datei, Arbeitsmappe und Worksheet erstellen
    Set ExcelApp = CreateObject("Excel.Application")
    Set wb = ExcelApp.Workbooks.Add
    Set ws = ExcelApp.Worksheets.Add
    ' Nur ausführen wenn Daten vorhanden sind
    If Not rs.EOF Then
        rs.MoveFirst
        ' Daten nach Excel kopieren
        For iCols = 0 To rs.Fields.Count - 1
            ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
        Next
        ws.Range(ws.Cells(1, 1), _
            ws.Cells(1, rs.Fields.Count)).Font.Bold = True
        ws.Range("A2").CopyFromRecordset rs
    End If
    ws.Columns.AutoFit
    ' Excel sichtbar machen und alles resetten
    ExcelApp.Visible = True
    Set ws = Nothing
    Set wb = Nothing
    Set ExcelApp = Nothing
End Sub

Und der Aufruf erfolgt mit:

Code:

XLSExportRS Me!Unterformular.Form.RecordsetClone

[ios707]

Noch ein Update:

- Bugfix: der Code konnte bislang nicht mehrmals hintereinander ausgeführt werden, weil nach der ersten Ausführung der DS-Marker des Recordsets am Ende steht. Ein MoveFirst an der richtigen Stelle schafft Abhilfe.
- Ergänzung: Meldung, wenn keine Daten für den Export vorliegen und in diesem Fall auch kein unnötiges Anlegen von Excel-Instanzen.

Der Code kommt nach wie vor in ein Modul:

Code:

Public Sub XLSExportRS(rs As Recordset)
' Export aller Daten des Unterformulars nach Excel mit CopyFromRecordset-Methode
' David Niegisch, 25.02.2010
Dim gsMsgAntw As Integer
Dim iCols As Integer
Dim ws As Object ' falls Verweise auf die Excel-Bibl. gesetzt sind, kann man sich late binding sparen, Excel.Worksheet
Dim wb As Object ' falls Verweise auf die Excel-Bibl. gesetzt sind, kann man sich late binding sparen, Excel.Workbook
Dim ExcelApp As Object ' falls Verweise auf die Excel-Bibl. gesetzt sind, kann man sich late binding sparen, Excel.Application

    ' MoveFirst sorgt dafür, dass die gleichen Daten auch mehrmals hintereinander exportiert werden können
    rs.MoveFirst
    
    ' Nur ausführen wenn Daten vorhanden sind
    If rs.EOF Then
        gsMsgAntw = MsgBox("Es sind keine Ergebnisse für einen Export vorhanden!", vbInformation, "Export nicht moeglich")
    Else
        ' Neue Excel Datei, Arbeitsmappe und Worksheet erstellen
        Set ExcelApp = CreateObject("Excel.Application")
        Set wb = ExcelApp.Workbooks.Add
        Set ws = ExcelApp.Worksheets.Add
        ' Daten nach Excel kopieren
        ' Feld- bzw. Spaltennamen
        For iCols = 0 To rs.Fields.Count - 1
            ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
        Next
        ' Daten
        ws.Range(ws.Cells(1, 1), _
            ws.Cells(1, rs.Fields.Count)).Font.Bold = True
        ws.Range("A2").CopyFromRecordset rs
        ' Spaltenbreite anpassen
        ws.Columns.AutoFit
        ' Excel sichtbar machen und alles resetten
        ExcelApp.Visible = True
        Set ws = Nothing
        Set wb = Nothing
        Set ExcelApp = Nothing
    End If
    
End Sub

Wenn der Code von einem Hauptformular aus die Daten eines Unterformulars exportieren soll, dann erfolgt der Aufruf mit:

Code:

XLSExportRS Me!Unterformular.Form.RecordsetClone

"Unterformular" ist dabei der Name des Steuerelements auf dem Hauptformular, in dem das Unterformular steckt.

[swati]

sehr schöner Code!

und funktioniert prima

[cpac]

Falls sich ein Feld vom Datentyp Memo im Recordset befindet, kommt es bei Verwendung von CopyFromRecordset zu einem Fehler, wenn sich mehr als 910 Zeichen in dem Memo-Feld befinden. Dies als Information (aus leidvoller Erfahrung...).

In einem solchen Fall ist dann DoCmd.TransferSpreadsheet eine funktionierende Lösung.

[ios707]

Danke für den Hinweis Carsten. Habe mal etwas nachgeforscht und eine Lösung für das Problem mit den Memo-Feldern gefunden, die ich selbst noch nicht ausprobiert habe.

Anscheinend ist es kein Problem, das Memo-Feld erst mal an eine Variable zu übergeben und dann den Inhalt der Variablen weiterzuverwenden, bspw. so

Code:

foo = rstcheck![Field Memo]
objsheet2.cells(4,2).value = foo

Quelle: http://www.utteraccess.com/forum/Cop...81#entry648781

Wie gesagt, nicht selber getestet und werde es in naher Zukunft wohl auch nicht machen, da ich das nicht brauche und genug andere Sachen zu tun habe