Question : VBA to Rearrange Excel Data and Apply Formatting

I’m looking for some VBA code that will rearrange the raw data in “SheetRaw” of my attached Excel file in the format you see on “SheetFinished”. The code below should inspire some thought with you experts out there. Any solutions to this are greatly appreciated! ;-)

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:



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

Attachments:

Example.xls (25 KB) (File Type Details)

Please see example file.

Question : VBA to Rearrange Excel Data and Apply Formatting

Answer : VBA to Rearrange Excel Data and Apply Formatting

try it again after correction