Add Subtotals After Each Data Break

jski

Board Regular
Joined
Jan 11, 2006
Messages
118
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.


Code:
' 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
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
This works with a column of numbers starting at H2 that has breaks of different sizes (one cell, two cells, three cells, etc) between the groups.

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))
Range("H" & lastrow).Offset(1, 0).Value = subt

lastrow = Cells(break, 8).End(xlUp).Row
If lastrow < 2 Then End

GoTo nxt

End Sub
 
Upvote 0
Somebody was yakking at me and I got distracted and neglected the code tags sorry...


Code:
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))
    Range("H" & lastrow).Offset(1, 0).Value = subt

    lastrow = Cells(break, 8).End(xlUp).Row
    If lastrow < 2 Then End
    
GoTo nxt

End Sub
 
Upvote 0
Thanks igold. This works great and will be a tremendous timesaver! If one needed to expand it to do the same for an adjacent column (Column I), could that be done or would it be necessary to run duplicate code after this for the additional column? I tried changing the column designation to "H:I" and received a 400 error.



jski
 
Upvote 0
Hi jski, Glad I could help. See if this does what you want. You have to do the columns separately.



Code:
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))
    Range("H" & lastrow).Offset(1, 0).Value = subt

    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))
    Range("I" & lastrow).Offset(1, 0).Value = subt

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

GoTo nxt2

End Sub

igold
 
Upvote 0
Bingo! Thanks again igold. This was a well-learned VBA lesson for me. I think I see how this works now. This is easily transferable to so many other things I'm doing. I'll probably add a bit to throw in some formatting for bolding the results and adding subtotal lines.


I very much appreciate your time and instruction. Enjoy your day!


jski
 
Upvote 0
That is great. Thank you very much for the feedback. Have a nice day as well.

igold
 
Upvote 0
So I've added a bit and the format looks good. I was done! However, the ever changing needs of management dictate the need to add text to a cell 1 row down and 2 columns to the left of each subtotal in Column H. Can this even be done given the dynamic nature of the subtotals?

Code:
' 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))
    Range("H" & lastrow).Offset(1, 0).Value = subt
    Range("H" & lastrow).Offset(1, 0).EntireRow.Font.Bold = True
    Range("H" & lastrow).Offset(1, 0).EntireRow.Font.Size = "9"
    Range("H" & lastrow).Offset(1, 0).EntireRow.Font.ColorIndex = xlColorIndexAutomatic
    Range("H" & lastrow).Offset(1, 0).EntireRow.NumberFormat = "$#,##0_);($#,##0)"
    Range("H" & lastrow).Offset(1, 0).EntireColumn.AutoFit
    Range("H" & lastrow).Offset(1, 0).Cells.Borders(xlEdgeTop).Weight = xlThin
        
    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))
    Range("I" & lastrow).Offset(1, 0).Value = subt
    Range("I" & lastrow).Offset(1, 0).EntireColumn.AutoFit
    Range("I" & lastrow).Offset(1, 0).Cells.Borders(xlEdgeTop).Weight = xlThin

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

GoTo nxt2
 
Upvote 0
Should not be a problem (famous last words). Do you know what the text is and will it change with every subtotal?
 
Upvote 0
Text will always be the same and it will be the same for every subtotal. Let's say the text is "waddya wan't now."
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top