Sub Zusammenfassen()
Dim wks As Worksheet
Dim intLetzteZeile As Integer
Dim intLetzteSpalte As Integer
Dim n As Integer
Dim intZeile As Integer
Dim intSpalte As Integer
Set wks = ThisWorkbook.Worksheets("Tabelle1")
intLetzteZeile = wks.Cells(Rows.Count, 2).End(xlUp).Row
intLetzteSpalte = wks.Cells(1, Columns.Count).End(xlToLeft).Column
For intZeile = 1 To intLetzteZeile
For intSpalte = 2 To intLetzteSpalte
With Cells(intZeile, intSpalte)
If .Value <> "" Then
.Copy .Offset(0, 7 - n)
Else
n = n + 1
End If
End With
Next intSpalte
n = 0
Next intZeile
End Sub