Sub Rearrange()
Dim Aarea As Range, Arange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Arange = Range("A10", Range("A" & Rows.Count).End(xlUp))
With Arange
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents
.Offset(, -1).EntireColumn.Delete
.EntireColumn.RemoveSubtotal
End With
For Each Aarea In Arange.SpecialCells(xlCellTypeConstants).Areas
With Aarea
With .Cells(1, 1).Offset(-1)
.Value = .Offset(1).Value
.Font.Bold = True
.EntireRow.Insert
End With
.ClearContents
End With
Next Aarea
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
|