Macro for multiple subtotals

Hello, i'm in need of some VBA help for an excel macro. I have a macro that takes data from one sheet and moves the relevant/needed data to a second sheet within the same workbook. Once the data is moved to a new sheet, the macro then separates the data based on the date by putting two lines in between each set of data as shown in the attached picture. What I would like to be able to do is subtotal each little group (generally anywhere between 1 and 3 lines) under the hours which is column J and that's where i'm stuck. I have everything else working properly except I am stumped on how to get column J subtotals for each little group to work. Any help would be greatly appreciated!

sample.JPG

Hi


this is how I would have done it... (there may be better ways, im no expert) ... but hope it helps

Sub MySubTotals()

Dim i, Lrow, MySubTotal

i = 2 'use this to loop through rows


'find the last row in column "J"
Lrow = Sheet1.Range("J99999").End(xlUp).Row + 1


' begin loop

Do While i <= Lrow
        
        MySubTotal = 0
            
            'inner loop while hours are present
            
            Do While Sheet1.Cells(i, 10) <> ""
                
                MySubTotal = MySubTotal + Sheet1.Cells(i, 10)
            
            i = i + 1
            Loop
            'add the sub total below last row of hours
            Sheet1.Cells(i, 10) = MySubTotal
            
        i = i + 1
        
Loop


End Sub

any chance you can post an example of the data?

Attached are two samples of the sheet that comes out once I get it separated into a second sheet. I need each small group that pertains to whatever date, to have it subtotal below the last row of that group.

Sample one: This sample has it before I run part of my macro that separates the rows into groups based on the date.

Sample two: This sample is what happens after the macro has been run to separate the rows into groups based on the date.

in your examples (both) your data is on sheet2. This is why my code did not work.

I have adjust it it accordingly.

I have also provide you with one to remove the sub totals we create with the first one... just in case

I only created this for the "SAMPLE DATA post macro"

I've tested it, and it workd

Sub MySubTotals()

Dim i, lrow, MySubTotal

i = 2 'use this to loop through rows


'find the last row in column "J"
lrow = Sheet2.Range("J99999").End(xlUp).Row + 1


' begin loop

Do While i <= lrow
        
        MySubTotal = 0
            
            'inner loop while hours are present
            
            Do While Sheet2.Cells(i, 10) <> ""
                
                MySubTotal = MySubTotal + Sheet2.Cells(i, 10)
            
            i = i + 1
            Loop
            
            'add the sub total below last row of hours
            If MySubTotal <> 0 Then
                Sheet2.Cells(i, 9) = "SubTotal"
                Sheet2.Cells(i, 10) = MySubTotal
            End If
            
            
        i = i + 1
        
Loop


End Sub


Sub remove_subtotal()

Dim i, lrow
    
i = 2 'use this to loop through rows


'find the last row in column "J"
lrow = Sheet2.Range("J99999").End(xlUp).Row + 1
    
    
    Do While i <= lrow
    
        If Sheet2.Cells(i, 9) = "SubTotal" Then
            Sheet2.Cells(i, 9) = ""
            Sheet2.Cells(i, 10) = ""
        End If
        i = i + 1
    Loop
    
    
End Sub

Thank you Jindon, that worked perfectly.

I appreciate your effort Steve7913