Variable Spaltennamen als Zeilen transponieren

[Knopf]

Hallo Experten!

ich habe eine Tabelle bei der sich einige Spaltennamen wöchentlich ändern. Um mit den Daten weiterarbeiten zu können, müssen die Spaltennamen als Zeilen gespeichert sein. Ich habe die Vorgabe das Ganze in VBA zu programmieren, nicht SQL.

Meine Ausgangstabelle: (Ändert sich wöchentlich, also fortlaufende Kalenderwoche)
Nr  Name    KWn+1     KWn+2    KWn+3
  1     abc         1           2         3

Meine Zieltabelle:
Nr   Name  KW        Anzahl
  1    abc     KWn+1      1
  1    abc     KWn+2      2
  1    abc     KWn+3      3

Bei meiner Suche bin ich auf dieses Makro gestoßen:
Function TransposeTable(strSourceObj As String, _
                        strTranspTable As String) As Boolean
    Dim db As DAO.Database
    Dim rsBasis As DAO.Recordset
    Dim rsTranspose As DAO.Recordset
    Dim tdfNewDef As DAO.TableDef
    Dim fldNewField As DAO.Field
    Dim I As Long, J As Long
    Dim intNumRecs As Long
    Dim intNumFields As Long

    TransposeTable = False 'Default-Rueckmeldung
    'Recordset für Basis-Tabelle initialisieren
    Set db = CurrentDb()
    Set rsBasis = db.OpenRecordset(strSourceObj)
    rsBasis.MoveLast
   
   
    '1.------------------------------------------------------------------------------------
    intNumFields = rsBasis.Fields.Count - 1
    For I = 0 To intNumFields
        If rsBasis.Fields(I).Type = dbMemo Or _
           rsBasis.Fields(I).Type = dbLongBinary Then
            Beep
            MsgBox "Tabelle " & strSourceObj & " beinhaltet spezielle " & _
                   "Felder, " & "die nicht komplett übernommen werden " & _
                   "können...", vbOKOnly + vbInformation, "!!! Hinweis !!!"
        End If
    Next I
    '2.-------------------------------------------------------------------------------------
    'Ziel-Tabelle anlegen/loeschen...
    DoCmd.Hourglass True
    DoEvents
    On Error Resume Next
    Set tdfNewDef = db.TableDefs(strTranspTable)
    If Err = 0 Then 'Tabelle ist vorhanden, loeschen
        DoCmd.SetWarnings False
        DoCmd.DeleteObject acTable, strTranspTable
        DoCmd.SetWarnings True
    End If
    '3.--------------------------------------------------------------------------------------
    Set tdfNewDef = db.CreateTableDef(strTranspTable)
    For I = 0 To rsBasis.RecordCount                                   
        Set fldNewField = tdfNewDef.CreateField(CStr(I + 1), dbText)
        tdfNewDef.Fields.Append fldNewField
    Next I
    Err = 0
    db.TableDefs.Append tdfNewDef
    If Err <> 0 Then
        DoCmd.Hourglass False
        Beep
        MsgBox "Tabelle " & strTranspTable & " konnte nicht angelegt " & _
               "werden..." & vbCrLf & vbCrLf & "Fehler: " & _
               CStr(Err.Number) & "/" & Err.Description, _
               vbOKOnly + vbExclamation, "!!! Probblem !!!"
        rsBasis.Close
        Exit Function
    End If
    '4.----------------------------------------------------------------------------------------
    'Recordset für Ziel-Tabelle initialisieren
    '1. Spalte mit Feldnamen fuellen
    Set rsTranspose = db.OpenRecordset(strTranspTable)
    For I = 0 To rsBasis.Fields.Count - 1
        With rsTranspose
            .AddNew
            .Fields(0) = rsBasis.Fields(I).Name
            .Update
        End With
    Next I
    'ab 2. Spalte mit Daten fuellen
    rsBasis.MoveFirst
    rsTranspose.MoveFirst
    '5.----------------------------------------------------------------------------------------
    For J = 0 To rsBasis.Fields.Count - 1
        For I = 1 To rsTranspose.Fields.Count - 1
            With rsTranspose
                .Edit
                .Fields(I) = rsBasis.Fields(J)
                rsBasis.MoveNext
                .Update
            End With
        Next I
        rsBasis.MoveFirst
        rsTranspose.MoveNext
    Next J
    'und fertig...
    TransposeTable = True
    rsBasis.Close
    rsTranspose.Close
    DoCmd.Hourglass False
End Function

Das funktioniert jetzt, macht aber nicht das was ich mir vorstelle^^ Ab dem 3. Punkt (da wird es erst interessant) komme ich nicht weiter. Es werden die Records gezählt. Ich müsste jetzt aber die Spaltennamen (1-2) anwählen und festlegen, dann einen neuen Spaltennamen für "KW" erstellen. Wie mache ich das? Ich hoffe ihr könnt mir helfen!
Vielen Dank!
lg
Knopf

[Beaker s.a.]

Hallo Knopf,
Auf das gezeigte Beispiel reduziert (Zieltabelle liegt mit gezeigter Struktur vor).

Code [Auswählen] Erweitern

Public Sub Transponse()

    Dim z As Integer
    Dim dbe As DAO.Database
    Dim rstQ As DAO.Recordset
    Dim rstZ As DAO.Recordset

    Set dbe = CurrentDb
    Set rstQ = dbe.OpenRecordset("Quelle")
   
    dbe.Execute "DELETE FROM Ziel"    '<- Zieltabelle wird geleert
    Set rstZ = dbe.OpenRecordset("Ziel")
   
    Do While Not rstQ.EOF
        For z = 2 To rstQ.Fields.Count - 1
            rstZ.AddNew
                rstZ.Fields(0) = rstQ.Fields(0)
                rstZ.Fields(1) = rstQ.Fields(1)
                rstZ.Fields(2) = rstQ.Fields(z).Name
                rstZ.Fields(3) = rstQ.Fields(z).Value
            rstZ.Update
        Next z
        rstQ.MoveNext
    Loop
End Sub
gruss ekkehard

[Knopf]

Es hat super funktioniert! Vielen lieben Dank )

[volvisti]

Hallo Beaker,
Danke für Deinen Tipp.
Hat bei mir auch, nach einer kleinen tabellenabhängigen Änderung, super funktioniert.

Jetzt habe ich den Code als Modul in der Db abgelegt.
Wie kann ich ihn shnell ausführen, ohne über den VBA-Editor gehen zu müssen?
@Knopf wie machst Du das?

Danke schon mal für die Hilfe.

Gruß
Volvisti

[Knopf]

Ich mache das über einen button im formular. Im klassenmodul starte ich dann mein modul. Über modulname.prozedurname .

[volvisti]

Hallo Knopf,
besten Dank.
Ich brauche es zwar nicht wirklich, hab mir aber ein Formular gebaut und die Schaltfläche integriert.
Klappt super. 

Schönen Tag noch
volvisti