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
Hallo Knopf,
Auf das gezeigte Beispiel reduziert (Zieltabelle liegt mit gezeigter Struktur vor).
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
Es hat super funktioniert! Vielen lieben Dank :))
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
Ich mache das über einen button im formular. Im klassenmodul starte ich dann mein modul. Über modulname.prozedurname .
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