Access 2010-导出到Excel-多行

Question

For our customer I need to export the data of three queries to an Excel-Template, with three sheets.

Here is my first try:

Private Sub btnEmail_Click()
    Dim appExcel As New Excel.Application

    strQuery1 = "Z_SL_Liste_Komplett"
    strSQL1 = "SELECT * FROM Z_SL_Liste_Komplett"

    strQuery2 = "Z_SL_Liste_OK"
    strSQL2 = "SELECT * FROM Z_SL_Liste_OK"

    strQuery3 = "Z_SL_Liste_nicht_OK"
    strSQL3 = "SELECT * FROM Z_SL_Liste_nicht_OK"

    Set rst1 = CurrentDb.OpenRecordset(strQuery1)
    Set rst2 = CurrentDb.OpenRecordset(strQuery2)
    Set rst3 = CurrentDb.OpenRecordset(strQuery3)

    strTemplate = "\\WINSER8\Allgemein_Rala\LU\SL_Zeugnisablage" & "\Template.xlsx"

    Set wkb = appExcel.Workbooks.Add(Template:=strTemplate)
    Set sht1 = wkb.Sheets(1)
    Set sht2 = wkb.Sheets(2)
    Set sht3 = wkb.Sheets(3)
    appExcel.Visible = True

    'Write data for selected vehicle to cells of worksheet
    rst1.Edit
    sht1.Range("A6").Value = rst1![Ansprechpartner]
    sht1.Range("B6").Value = rst1![Rala SL-Nr]
    sht1.Range("C6").Value = rst1![Einsatzort]
    sht1.Range("D6").Value = rst1![Knd SL-Nr]
    sht1.Range("E6").Value = rst1![Hersteller/Schlauchtyp]
    sht1.Range("F6").Value = rst1![Alter]
    sht1.Range("G6").Value = rst1![DN]
    sht1.Range("H6").Value = rst1![Länge]
    sht1.Range("I6").Value = rst1![PN]
    sht1.Range("J6").Value = rst1![PS]
    sht1.Range("K6").Value = rst1![EL-Art]
    sht1.Range("L6").Value = rst1![AS 1 & 2]
    sht1.Range("M6").Value = rst1![Sicht-Ergebnis]
    sht1.Range("N6").Value = rst1![EL-Ergebnis]
    sht1.Range("O6").Value = rst1![Druck-Ergebnis]
    sht1.Range("P6").Value = rst1![Gesamtergebnis]
    sht1.Range("Q6").Value = rst1![Prüfer (Befähigte Person)]
    sht1.Range("R6").Value = rst1![Prüfintervall]
    sht1.Range("S6").Value = rst1![Bemerkung]
    sht1.Range("T6").Value = rst1![Farbcodierung]
    rst1.Update

    rst2.Edit
    sht2.Range("A6").Value = rst2![Ansprechpartner]
    sht2.Range("B6").Value = rst2![Rala SL-Nr]
    sht2.Range("C6").Value = rst2![Einsatzort]
    sht2.Range("D6").Value = rst2![Knd SL-Nr]
    sht2.Range("E6").Value = rst2![Hersteller/Schlauchtyp]
    sht2.Range("F6").Value = rst2![Alter]
    sht2.Range("G6").Value = rst2![DN]
    sht2.Range("H6").Value = rst2![Länge]
    sht2.Range("I6").Value = rst2![PN]
    sht2.Range("J6").Value = rst2![PS]
    sht2.Range("K6").Value = rst2![EL-Art]
    sht2.Range("L6").Value = rst2![AS 1 & 2]
    sht2.Range("M6").Value = rst2![Sicht-Ergebnis]
    sht2.Range("N6").Value = rst2![EL-Ergebnis]
    sht2.Range("O6").Value = rst2![Druck-Ergebnis]
    sht2.Range("P6").Value = rst2![Gesamtergebnis]
    sht2.Range("Q6").Value = rst2![Prüfer (Befähigte Person)]
    sht2.Range("R6").Value = rst2![Prüfintervall]
    sht2.Range("S6").Value = rst2![Bemerkung]
    sht2.Range("T6").Value = rst2![Farbcodierung]
    rst2.Update

    rst3.Edit
    sht3.Range("A6").Value = rst3![Ansprechpartner]
    sht3.Range("B6").Value = rst3![Rala SL-Nr]
    sht3.Range("C6").Value = rst3![Einsatzort]
    sht3.Range("D6").Value = rst3![Knd SL-Nr]
    sht3.Range("E6").Value = rst3![Hersteller/Schlauchtyp]
    sht3.Range("F6").Value = rst3![Alter]
    sht3.Range("G6").Value = rst3![DN]
    sht3.Range("H6").Value = rst3![Länge]
    sht3.Range("I6").Value = rst3![PN]
    sht3.Range("J6").Value = rst3![PS]
    sht3.Range("K6").Value = rst3![EL-Art]
    sht3.Range("L6").Value = rst3![AS 1 & 2]
    sht3.Range("M6").Value = rst3![Sicht-Ergebnis]
    sht3.Range("N6").Value = rst3![EL-Ergebnis]
    sht3.Range("O6").Value = rst3![Druck-Ergebnis]
    sht3.Range("P6").Value = rst3![Gesamtergebnis]
    sht3.Range("Q6").Value = rst3![Prüfer (Befähigte Person)]
    sht3.Range("R6").Value = rst3![Prüfintervall]
    sht3.Range("S6").Value = rst3![Bemerkung]
    sht3.Range("T6").Value = rst3![Farbcodierung]
    rst3.Update
End Sub

My problem is the direct "connection" A6; B6 etc. My source have more than one row. So I need a loop or something like this. An array?

For example: In source are 5 rows, but later in Excel only one!

Please help me.

THX.

Vegeta77

Answer 1

Quite a few issues with your code but I won't go into detail. I will only point out that it's very important to declare your variables by using Option Explicit at the top of each Module.

You can set it to be added automatically in Tools/Options/Require Variable Declaration of the VBA editor.

Here's a revised version of your code. Compare it with yours to see the differences.

Option Explicit

Private Sub btnEmail_Click()
    On Error GoTo ErrProc

    Const strTemplate = "\\WINSER8\Allgemein_Rala\LU\SL_Zeugnisablage\Template.xlsx"

    Dim strSQL1 As String, strSQL2 As String, strSQL3 As String

    strSQL1 = "SELECT * FROM Z_SL_Liste_Komplett"
    strSQL2 = "SELECT * FROM Z_SL_Liste_OK"
    strSQL3 = "SELECT * FROM Z_SL_Liste_nicht_OK"

    Dim rst1 As DAO.Recordset
    Set rst1 = CurrentDb.OpenRecordset(strSQL1)
    With rst1
        If Not .EOF Then
            .MoveLast
            .MoveFirst
        End If
    End With

    Dim rst2 As DAO.Recordset
    Set rst2 = CurrentDb.OpenRecordset(strSQL2)
    With rst2
        If Not .EOF Then
            .MoveLast
            .MoveFirst
        End If
    End With

    Dim rst3 As DAO.Recordset
    Set rst3 = CurrentDb.OpenRecordset(strSQL3)
    With rst3
        If Not .EOF Then
            .MoveLast
            .MoveFirst
        End If
    End With

    Dim errFlag As Boolean
    Dim appExcel As Excel.Application
    Set appExcel = New Excel.Application
        appExcel.Visible = True

    Dim wkb As Excel.Workbook
    Set wkb = appExcel.Workbooks.Add(Template:=strTemplate)

    Dim sht1 As Excel.Worksheet
    Set sht1 = wkb.Sheets(1)

    Dim sht2 As Excel.Worksheet
    Set sht2 = wkb.Sheets(2)

    Dim sht3 As Excel.Worksheet
    Set sht3 = wkb.Sheets(3)

    Dim counter_ As Long 
        counter_ = 6 'assuming starts at row 6

    Dim idx As Long
    With sht1
        For idx = 1 To rst1.RecordCount

            'Write data for selected vehicle to cells of worksheet
            .Range("A" & counter_).Value = rst1![Ansprechpartner]
            .Range("B" & counter_).Value = rst1![Rala SL-Nr]
            .Range("C" & counter_).Value = rst1![Einsatzort]
            .Range("D" & counter_).Value = rst1![Knd SL-Nr]
            .Range("E" & counter_).Value = rst1![Hersteller/Schlauchtyp]
            .Range("F" & counter_).Value = rst1![Alter]
            .Range("G" & counter_).Value = rst1![DN]
            .Range("H" & counter_).Value = rst1![Länge]
            .Range("I" & counter_).Value = rst1![PN]
            .Range("J" & counter_).Value = rst1![PS]
            .Range("K" & counter_).Value = rst1![EL-Art]
            .Range("L" & counter_).Value = rst1![AS 1 & 2]
            .Range("M" & counter_).Value = rst1![Sicht-Ergebnis]
            .Range("N" & counter_).Value = rst1![EL-Ergebnis]
            .Range("O" & counter_).Value = rst1![Druck-Ergebnis]
            .Range("P" & counter_).Value = rst1![Gesamtergebnis]
            .Range("Q" & counter_).Value = rst1![Prüfer (Befähigte Person)]
            .Range("R" & counter_).Value = rst1![Prüfintervall]
            .Range("S" & counter_).Value = rst1![Bemerkung]
            .Range("T" & counter_).Value = rst1![Farbcodierung]

            counter_ = counter_ + 1
            rst1.MoveNext
        Next idx
    End With

    counter_ = 6 'reset

    With sht2
        For idx = 1 To rst2.RecordCount

            'Write data for selected vehicle to cells of worksheet
            .Range("A" & counter_).Value = rst2![Ansprechpartner]
            .Range("B" & counter_).Value = rst2![Rala SL-Nr]
            .Range("C" & counter_).Value = rst2![Einsatzort]
            .Range("D" & counter_).Value = rst2![Knd SL-Nr]
            .Range("E" & counter_).Value = rst2![Hersteller/Schlauchtyp]
            .Range("F" & counter_).Value = rst2![Alter]
            .Range("G" & counter_).Value = rst2![DN]
            .Range("H" & counter_).Value = rst2![Länge]
            .Range("I" & counter_).Value = rst2![PN]
            .Range("J" & counter_).Value = rst2![PS]
            .Range("K" & counter_).Value = rst2![EL-Art]
            .Range("L" & counter_).Value = rst2![AS 1 & 2]
            .Range("M" & counter_).Value = rst2![Sicht-Ergebnis]
            .Range("N" & counter_).Value = rst2![EL-Ergebnis]
            .Range("O" & counter_).Value = rst2![Druck-Ergebnis]
            .Range("P" & counter_).Value = rst2![Gesamtergebnis]
            .Range("Q" & counter_).Value = rst2![Prüfer (Befähigte Person)]
            .Range("R" & counter_).Value = rst2![Prüfintervall]
            .Range("S" & counter_).Value = rst2![Bemerkung]
            .Range("T" & counter_).Value = rst2![Farbcodierung]

            counter_ = counter_ + 1
            rst2.MoveNext
        Next idx
    End With

    counter_ = 6 'reset

    With sht3
        For idx = 1 To rst3.RecordCount

            'Write data for selected vehicle to cells of worksheet
            .Range("A" & counter_).Value = rst3![Ansprechpartner]
            .Range("B" & counter_).Value = rst3![Rala SL-Nr]
            .Range("C" & counter_).Value = rst3![Einsatzort]
            .Range("D" & counter_).Value = rst3![Knd SL-Nr]
            .Range("E" & counter_).Value = rst3![Hersteller/Schlauchtyp]
            .Range("F" & counter_).Value = rst3![Alter]
            .Range("G" & counter_).Value = rst3![DN]
            .Range("H" & counter_).Value = rst3![Länge]
            .Range("I" & counter_).Value = rst3![PN]
            .Range("J" & counter_).Value = rst3![PS]
            .Range("K" & counter_).Value = rst3![EL-Art]
            .Range("L" & counter_).Value = rst3![AS 1 & 2]
            .Range("M" & counter_).Value = rst3![Sicht-Ergebnis]
            .Range("N" & counter_).Value = rst3![EL-Ergebnis]
            .Range("O" & counter_).Value = rst3![Druck-Ergebnis]
            .Range("P" & counter_).Value = rst3![Gesamtergebnis]
            .Range("Q" & counter_).Value = rst3![Prüfer (Befähigte Person)]
            .Range("R" & counter_).Value = rst3![Prüfintervall]
            .Range("S" & counter_).Value = rst3![Bemerkung]
            .Range("T" & counter_).Value = rst3![Farbcodierung]

            counter_ = counter_ + 1
            rst3.MoveNext
        Next idx
    End With


Leave:
    On Error Resume Next
        rst1.Close
    Set rst1 = Nothing
        rst2.Close
    Set rst2 = Nothing
        rst3.Close
    Set rst3 = Nothing
    Set sht1 = Nothing
    Set sht2 = Nothing
    Set sht3 = Nothing

    If errFlag Then
        appExcel.Close SaveChanges:=False
        appExcel.Quit
    End If

    Set wkb = Nothing
    Set appExcel = Nothing

    On Error GoTo 0
Exit Sub

ErrProc:
    MsgBox Err.Description, vbCritical
    errFlag = True
    Resume Leave
End Sub