Why are the dashes added? I'm guessing that isn't intended.
Try this on a test worksheet.
Put a single group's worth of data in A2:k8
Then select A2:K2.
Now hit ctrl-g (or F5 or edit|goto in xl2003 menus).
Hit Special, then blanks, then Ok.
Then Edit|delete|shift cells up
Does that work ok for that single group?
If yes, then try this macro. It creates a new sheet and copies over a single
group at a time and does the same thing for each group.
Option Explicit
Sub testme()
Dim NewWks As Worksheet
Dim OldWks As Worksheet
Dim DummyRng As Range
Dim TopCell As Range
Dim BotCell As Range
Dim DestCell As Range
Dim ThisGroupRng As Range
Dim myUniqueString As String
Dim myLastCell As Range
myUniqueString = String(50, vbLf)
Set OldWks = Worksheets("Sheet1") '<-- change name here
Set NewWks = Worksheets.Add
Set DestCell = NewWks.Range("A1")
With OldWks
'try to reset the last used cell
Set DummyRng = .UsedRange
'add a dummy entry to the bottom of column A
Set myLastCell = .Cells.SpecialCells(xlCellTypeLastCell) _
.EntireRow.Cells(1).Offset(1, 0)
myLastCell.Value = myUniqueString
Set TopCell = .Range("A2")
If IsEmpty(TopCell.Value) Then
TopCell.Value = "AAAAAA"
End If
Do
If IsEmpty(TopCell.Offset(1, 0).Value) = False Then
Set BotCell = TopCell 'just a single row
Else
If IsEmpty(TopCell.Offset(2, 0).Value) = False Then
Set BotCell = TopCell.Offset(1, 0) 'two rows
Else
'go down to the next used cell and then up one row
Set BotCell = TopCell.End(xlDown).Offset(-1, 0)
End If
End If
.Range(TopCell, BotCell).EntireRow.Copy _
Destination:=DestCell
With NewWks
'just the newly copied group
Set ThisGroupRng _
= DestCell.Resize(BotCell.Row - TopCell.Row + 1).EntireRow
'in case there are no emtpy cells in that group
On Error Resume Next
ThisGroupRng.Cells.SpecialCells(xlCellTypeBlanks).Delete _
shift:=xlShiftUp
On Error GoTo 0
'try to reset the last used cell
Set DummyRng = .UsedRange
Set DestCell = .Cells.SpecialCells(xlCellTypeLastCell) _
.EntireRow.Cells(1).Offset(1, 0)
End With
'get ready for the next group
Set TopCell = BotCell.Offset(1, 0)
If TopCell.Value = myUniqueString Then
Exit Do 'we're done
End If
Loop
myLastCell.Value = "" 'clear up that last cell
End With
End Sub
