Sub So()
Dim rColumn As Range, rArea As Range
Set rColumn = Columns(1).ColumnDifferences(Cells(Rows.Count, 1))
For Each rArea In rColumn.Areas
If rArea.Rows.Count = 1 Then
wrBack rArea.Rows(1).EntireRow, rArea.Rows(1).EntireRow
Else
wrBack rArea.Rows(rArea.Rows.Count).EntireRow, rArea.Rows(1).EntireRow
End If
Next rArea
End Sub
Private Sub wrBack(rw As Range, rt As Range)
Dim v(1 To 5), x, y
For x = 1 To 5
If rw.Cells(x) <> "" Then
v(y + 1) = rw.Cells(x)
y = y + 1
End If
Next x
rt.Cells(7).Resize(, 5).Value = v
End Sub