Autosum

Hi,

I have a code that looks at separates blocks of distinct cells with an empty line, then inserts a Autosum formula in that line and indicates that it is a subtotal.

My problem is that instead of auto-summing the numbers corresponding to the distinct block of cells, it sum formula extends to the top of the spreadsheet?

Besides that problem, is there a smarter way I could write this macro?

Thanks in advance!!

Sub AutoSum()
    Dim SheetCount As Long
    Dim r As Long
    Dim cel1, cel2
    
    For SheetCount = 1 To Worksheets.Count
         
        Dim Sh As Worksheet
        Worksheets(SheetCount).Activate
         
        With ActiveSheet

For r = Cells(Rows.Count, 2).End(xlUp).Row To 3 Step -1
    If Cells(r - 1, 1) <> Cells(r, 1) Then
        With Cells(r, 1)
            .EntireRow.Insert
            .Offset(-1).Interior.ColorIndex = 35
            .Offset(-1).Value = "Subtotal"
                  .Offset(-2, 5).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 6).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 7).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 8).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 9).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 10).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"
                                    .Offset(-2, 11).Select
                  cel1 = Selection.End(xlUp).Address
                  cel2 = ActiveCell.Address
                  ActiveCell.Offset(1, 0).Select
                  ActiveCell.Value = "=sum(" & (cel1) & ":" & (cel2) & ")"

              End With
              End If
              Next r
             
            End With
         
    Next SheetCount
    
End Sub