Sub x()
Dim c As Long
Dim r As Long
Dim z As Long
Dim Bereich As Range
Dim rng As Range
c = Cells(1, Columns.Count).End(xlToLeft).Column
r = Cells(Rows.Count, 1).End(xlUp).Row
Set Bereich = Range(Cells(2, 3), Cells(r, c))
z = 6
For Each rng In Bereich
If rng <> "" Then
Cells(z, 1).Value = Cells(rng.Row, 1).Value
Cells(z, 2).Value = Cells(rng.Row, 2).Value
Cells(z, 3).Value = rng.Value
z = z + 1
End If
Next rng
End Sub