a littlle awkward but Maybe:
Sub Aquabat()
Dim rcell As Range
Dim x As Long
Dim y As Long
Dim aa As Integer
Dim bb As Integer
Application.ScreenUpdating = False
For Each rcell In Range("C1:C" & ActiveSheet.UsedRange.Rows.count)
If rcell.Value <> "" Then
rcell.Select
x = ActiveSheet.UsedRange.Columns.count - 2
Do Until x = 0
If ActiveCell.Value <> "" Then
ActiveCell.Copy
ActiveCell.Offset(1, -1).Insert xlDown
ActiveCell.Offset(, -2).Copy
ActiveCell.Offset(1, -2).Insert xlDown
End If
Range(ActiveCell.Offset(, 1), ActiveCell.Offset(, ActiveSheet.UsedRange.Columns.count)).Copy ActiveCell.Offset(1)
Range(ActiveCell.Offset(2), ActiveCell.Offset(2, ActiveSheet.UsedRange.Columns.count)).Insert xlDown
ActiveCell.Delete xlToLeft
x = x - 1
Loop
End If
Next rcell
Columns("C:C").Insert
Range("A1").Select
Do Until ActiveCell.Value = ""
y = 0
ActiveCell.Offset(, 2).Value = y
If ActiveCell.Offset(1).Value = ActiveCell.Value Then
Do Until ActiveCell.Value <> ActiveCell.Offset(1).Value
y = y + 1
ActiveCell.Offset(, 2).Value = y
ActiveCell.Offset(1).Select
Loop
End If
ActiveCell.Offset(1).Select
Loop
For Each rcell In Range("C2:C" & Range("A" & Rows.count).End(3)(2).Row)
If rcell.Value = "" Then rcell.Value = rcell.Offset(-1).Value + 1
Next rcell
Range("C1").Select
zz:
If ActiveCell.Value = 1 Then aa = ActiveCell.Row
Do Until ActiveCell.Offset(1).Value = 0
ActiveCell.Offset(1).Select
Loop
bb = ActiveCell.Row
Range("B" & aa + 1 & ":C" & bb).Select
Selection.Sort Key1:=Range("C" & aa + 1), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C" & bb + 1).Select
If ActiveCell.Offset(1).Value = "" Then
Columns("C:C").Delete
Exit Sub
End If
Do Until ActiveCell.Value = 1
ActiveCell.Offset(1).Select
Loop
If ActiveCell.Value = 1 Then GoTo zz
Columns("C:C").Delete
Application.ScreenUpdating = True
End Sub
Bookmarks