Sub DatenTranspondieren()
Dim rngSrc As Range
Dim shDest As Worksheet
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")
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
strName = rng.Value
Case Else
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