Public Sub FoldSixLines()
  Dim i As Integer
  Dim j As Integer

  i = 1
  While Not IsTerminate(i)
    For j = 1 To 5
      ActiveSheet.Cells(i, j + 1).Value = ActiveSheet.Cells(i + j, 1).Value
    Next j
    ActiveSheet.Range(Cells(i + 1, 1), Cells(i + 5, 1)).Delete Shift:=xlShiftUp
    i = i + 1
  Wend
End Sub

Private Function IsTerminate(lineno As Integer) As Boolean
  Dim i As Integer
  For i = 0 To 5
    If ActiveSheet.Cells(lineno + i, 1).Value <> "" Then
      IsTerminate = False
      Exit Function
    End If
  Next i
  IsTerminate = True
End Function