Einzelnen Beitrag anzeigen
Alt 03.07.2017, 09:54   #3
ebs17
MOF Guru
MOF Guru
Standard

Der Code der verwendeten Funktion enthält in obiger Anlage noch einen Unterlassungsfehler. Da Recordsetfelder wie üblich bei Auflistungen 0-basiert gezählt werden, muss man das bei der Schleife (Übertragung der Matrixinhalte) berücksichtigen.
Korrektur ist farbig markiert:
Code:

Sub beispielaufruf_PivotToList()
    Dim bRet As Boolean

    ' Verknüpfen einer Exceltabelle
    DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel8, "Pivottabelle_XL", _
                              CurrentProject.Path & "Pivottabelle_Beispiel.xls", True

    bRet = PivotToList("Pivottabelle_XL", "Listtabelle", 4, "Art", "Betrag", dbLong, False, False)
    If bRet Then Debug.Print "Die Tabellenerstellung sollte geklappt haben."

    ' Entknüpfen der Exceltabelle
    DoCmd.DeleteObject acTable, "Pivottabelle_XL"
    
End Sub

Public Function PivotToList(ByVal NamePivotTable As String, _
                            ByVal NameListTable As String, _
                            ByVal NumberFirstMatrixField As Byte, _
                            ByVal NameTitleField As String, _
                            ByVal NameValueField As String, _
                            ByVal TypeValuefield As DataTypeEnum, _
                            Optional ByVal UseNullValues As Boolean = False, _
                            Optional ByVal IntoNewTable As Boolean = False) As Boolean
    On Error GoTo ErrHandler
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim sSQL As String
    Dim sConstantFields As String
    Dim bExistsTable As Boolean
    Dim i As Long

    Set dbs = CurrentDb

    bExistsTable = TableExistsDAO(dbs, NameListTable)
    If IntoNewTable Then
        If bExistsTable Then dbs.TableDefs.Delete NameListTable
    End If

    Set rst = dbs.OpenRecordset(NamePivotTable, dbOpenSnapshot)
    With rst
        If Not bExistsTable Or IntoNewTable Then
            ' Listtabelle neu erstellen
            Set tdf = dbs.CreateTableDef(NameListTable)
            For i = 0 To NumberFirstMatrixField - 2
                Set fld = tdf.CreateField(.Fields(i).Name, .Fields(i).Type)
                tdf.Fields.Append fld
                sConstantFields = sConstantFields & "[" & .Fields(i).Name & "], "
            Next
            Set fld = tdf.CreateField(NameTitleField, dbText)
            tdf.Fields.Append fld
            Set fld = tdf.CreateField(NameValueField, TypeValuefield)
            tdf.Fields.Append fld
            dbs.TableDefs.Append tdf
            RefreshDatabaseWindow
        End If

        ' Inhalte übertragen
        sConstantFields = ""
        For i = 0 To NumberFirstMatrixField - 2
            sConstantFields = sConstantFields & "[" & .Fields(i).Name & "], "
        Next
        For i = NumberFirstMatrixField - 1 To .Fields.Count - 1

            sSQL = "INSERT INTO " & NameListTable & " (" & sConstantFields & "[" & _
                   NameTitleField & "], [" & NameValueField & "])" & _
                   " SELECT " & sConstantFields & "'" & .Fields(i).Name & "', [" & _
                   .Fields(i).Name & "] FROM " & NamePivotTable
            If Not UseNullValues Then
                sSQL = sSQL & " WHERE [" & .Fields(i).Name & "] IS NOT NULL"
            End If
            dbs.Execute sSQL, dbFailOnError
        Next

        .Close
    End With

    '    ' Beispiel für ein Setzen eines zusammengesetzten Index
    '    sSQL = "CREATE INDEX NachnameVorname ON Listtabelle(Nachname, Vorname)"
    '    dbs.Execute sSQL, dbFailOnError

    Set rst = Nothing
    Set dbs = Nothing

    PivotToList = True

Exit_Function:
    Exit Function
ErrHandler:
    MsgBox "Fehler: " & vbTab & Err.Number & vbCrLf & Err.Description
    Resume Exit_Function
End Function

Public Function TableExistsDAO(pDb As DAO.Database, _
                               ByVal psName As String) As Boolean
    Dim s As String

    On Error Resume Next
    s = pDb.TableDefs(psName).Name
    TableExistsDAO = (Err.Number = 0)
End Function

__________________

Ein freundliches Glück Auf!

Eberhard

Abfrageperformance ist kein Geheimnis
SQL ist leicht: {0}:{1}:{2}:{3}:{4}:{5}:{6}:{7}:{8}:{9}:{10}:{11}
Dein Dankeschön: DBWiki=>Spende

Geändert von ebs17 (03.07.2017 um 09:56 Uhr).
ebs17 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten