Hallo,
es ist relativ simpel:
Sub DatenTranspondieren()
Dim rngSrc As Range ' Quelle
Dim shDest As Worksheet ' Ziel
Dim iRowSrc As Integer, iRowDest As Integer
Dim rng As Range
Dim strName As String
Set rngSrc = ActiveWorkbook.Names("Daten").RefersToRange
Set shDest = ActiveWorkbook.Worksheets("Ergebnis")
' Löschen im Ziel etwaige Vorhandene Einträge
With shDest
.UsedRange.Delete
.Range("A1").Value = "Name"
.Range("B1").Value = "Zielgewicht"
.Range("C1").Value = "Datum von"
.Range("D1").Value = "Datum bis"
End With
iRowDest = 2
For iRowSrc = 2 To rngSrc.Worksheet.UsedRange.Rows.Count
For Each rng In rngSrc.Rows(iRowSrc).Cells
Select Case rng.Column
Case 1
' Name
strName = rng.Value
Case Else
' Monate
With shDest
.Cells(iRowDest, 1).Value = strName
With .Cells(iRowDest, 2)
.Value = rng.Value
.NumberFormat = rng.NumberFormat
End With
.Cells(iRowDest, 3).Value = rng.Worksheet.Cells(1, rng.Column).Value
.Cells(iRowDest, 4).Value = DateAdd("d", -1, DateAdd("m", 1, rng.Worksheet.Cells(1, rng.Column).Value))
iRowDest = iRowDest + 1
End With
End Select
Next
Next
End Sub
Für die Funktionsfähigkeit dieses VBA-Codes müssen die Daten in Tabelle1 mit "Daten" benannt werden.
Zusätzlich muss eine Tabelle "Ergebnis" vorhanden sein.
Verweise braucht man hier nicht. Es sind auch nur zwei Schleifen erforderlich. Eine Schleife geht alle Zeilen ab der 2. durch. Die andere Schleife geht die Spalten durch, um die Angaben einlesen zu können.
Eine Beispieldatei kann von der Dropbox heruntergeladen werden:
https://www.dropbox.com/s/xgrqujx02218bda/Transpondieren.xlsm?dl=0
LG, BigBen
|