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

Quite possibly. I suggest you attach a small sample workbook illustrating how your data are arranged and your desired results.

File attached!

Basically it separates the data based on the code in column A and subtotals it, the loops through each tab (normally there are ~50 tabs)

However, each subtotal reaches to the top of the spreadsheet.

Try this. I had to put in some dummy data as you have some odd formatting.

Sub x()

Dim ws As Worksheet, r As Long, r2 As Long

For Each ws In Worksheets
    r2 = 2: r = 2
    With ws
        Do While Not IsEmpty(.Cells(r, 2))
            r = r + 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(-1, 5).Resize(, 7).Formula = "=SUM(F" & r2 & ":F" & r - 1 & ")"
                    r = r + 1
                    r2 = r
                End With
            End If
        Loop
    End With
Next ws

End Sub

Originally Posted by StephenR

Try this. I had to put in some dummy data as you have some odd formatting.

You've successfully taken my clunker code and turned it into a new model!!

one again, I really appreciate your help... ur too good!

Originally Posted by StephenR

Try this. I had to put in some dummy data as you have some odd formatting.

Quick question, how would I bold and create a line above each subtotal line ??

Try this. On reflection, you could have used Excel's built-in Subtotal feature.

Sub x()

Dim ws As Worksheet, r As Long, r2 As Long

For Each ws In Worksheets
    r2 = 2: r = 2
    With ws
        Do While Not IsEmpty(.Cells(r, 2))
            r = r + 1
            If .Cells(r - 1, 1) <> .Cells(r, 1) Then
                With .Cells(r, 1)
                    .EntireRow.Insert
                    With .Offset(-1)
                        .Interior.ColorIndex = 35
                        .Value = "Subtotal"
                        .Offset(, 5).Resize(, 7).Formula = "=SUM(F" & r2 & ":F" & r - 1 & ")"
                        .Resize(, 13).Font.Bold = True
                        .Resize(, 13).Borders(xlEdgeTop).Weight = xlMedium
                    End With
                    r = r + 1
                    r2 = r
                End With
            End If
        Loop
    End With
Next ws

End Sub