Add Subtotals After Each Data Break

[jski]

Good morning, good afternoon and good evening to all,

I can't seem to get this to insert a subtotal after each break I've created in my extract. It only installs a total after the first instance and not the others. Also, it only works in column H but I need it to install a total in column I as well.

' Add Subtotals
Dim ThisCell As Range
Dim MySum As Double
 
    Set ThisCell = Range("H2")
 
nxt:
 
    Do While ThisCell <> ""
        MySum = MySum + ThisCell
        Set ThisCell = ThisCell.Offset(1, 0)
    Loop
 
    ThisCell.Value = MySum
 
    If ThisCell.Offset(1, 0) <> "" Then
        Set ThisCell = ThisCell.Offset(1, 0)
        MySum = 0
        GoTo nxt
    End If

I have about five breaks currently but it could vary depending on the pulled data. Thanks in advance for your generous consideration.

jski

 

[igold]

Hi jski,

I am getting some undesired results in your formatting. I would like to correct but I am unsure if that is what you want. Do all your data breaks on col H and col I fall at the same place all the time.. as shown below in black, or can col I have data down to row 6 and then break as shown in orange...

	H	I	J
1
2	3	8
3	10	6
4	15	9
5		8
6		11
7

<tbody>
</tbody>

 

[jski]

Columns H and I will always fall at the same place all the time.

 

[igold]

Ok then, the way you have it works...

 

[igold]

Hi jski: This should do it. I did take the liberty of cleaning up just a bit. Also I moved the "autofit" to one line at the end of the code but this will autofit the whole worksheet. I commented out your lines instead of deleting them. If you do not want to autofit the entire sheet so you can easily use your lines and change the last few line lines accordingly.

Sub Getsubs()

' Add Subtotals

    Dim subt As Double
    Dim break As Single
    Dim lastrow As Single
        
    lastrow = Cells(Rows.Count, "H").End(xlUp).Row
    
nxt:

    break = Cells(lastrow, "H").End(xlUp).Row
    
    subt = WorksheetFunction.Sum(Range("H" & break, "H" & lastrow))
    
    With Range("H" & lastrow).Offset(1, 0)
        .Value = subt
        .EntireRow.Font.Bold = True
        .EntireRow.Font.Size = "9"
        .EntireRow.Font.ColorIndex = xlColorIndexAutomatic
        .EntireRow.NumberFormat = "$#,##0_);($#,##0)"
        '.EntireColumn.AutoFit
        .Cells.Borders(xlEdgeTop).Weight = xlThin
    End With
    
    Range("H" & lastrow).Offset(2, -2).Value = "waddya wan't now."
        
    lastrow = Cells(break, 8).End(xlUp).Row
    If lastrow < 2 Then GoTo newcol
    
GoTo nxt

newcol:

    lastrow = Cells(Rows.Count, "I").End(xlUp).Row
    
nxt2:

    break = Cells(lastrow, "I").End(xlUp).Row
    subt = WorksheetFunction.Sum(Range("I" & break, "I" & lastrow))
    
    With Range("I" & lastrow).Offset(1, 0)
        .Value = subt
        '.EntireColumn.AutoFit
        .Cells.Borders(xlEdgeTop).Weight = xlThin
    End With

    lastrow = Cells(break, "I").End(xlUp).Row
    If lastrow < 2 Then GoTo fmat

GoTo nxt2

fmat:

Cells.Columns.AutoFit

End Sub

Let me know how this works for you...

Regards,

igold

 

[jski]

Beautiful. Thanks igold. The cleanup looks good and I see how I can trim code for brevity and speed. This is most helpful for so many applications. The pages aren't breaking as I'd like but I'll try to reset them first and insert them where I need them in my final VBA step.


Thanks again for your help and instruction. All the best to you.

jski


jski

 

[igold]

No problem. Again, thanks for the feedback.

Regards,

igold