访问 2010 - 导出到 Excel - 多行

Question

对于我们的客户，我需要将三个查询的数据导出到带有三张工作表的 Excel 模板中。

这是我的第一次尝试：

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 = "\WINSER8Allgemein_RalaLUSL_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

我的问题是直接"连接"A6;B6等我的源有多个行。所以我需要一个循环或类似的东西。数组？

例如：在源代码中有 5 行，但后来在 Excel 中只有一行！

请帮助我。

感谢。

贝吉塔77

Answer 1

你的代码有很多问题，但我不会详细介绍。我只想指出，在每个模块的顶部使用Option Explicit声明变量非常重要。

您可以将其设置为在VBA编辑器的工具/选项/需要变量声明中自动添加。

下面是代码的修订版本。将其与您的进行比较以查看差异。

Option Explicit
Private Sub btnEmail_Click()
    On Error GoTo ErrProc
    Const strTemplate = "\WINSER8Allgemein_RalaLUSL_ZeugnisablageTemplate.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