How to move accounting information from one tab to another while adding a "sum" with changing data

[Hollywood9819]

How do I populate data from one tab to another while adding a row with a "sum" between different sections (such as "program" in my visual aid). The problem is figuring out how to populate the new tab while information in the original data tab could have more (or less) "programs" added or subtracted each week. Because of this, doing a simple (=) from one tab to the other to populate data will not work as if I get more "programs" than what I originally set the new tab up to populate, I will be missing data, or it would be pushed to a different program. Attached is an example of the format I am trying to achieve. I need rows in the new tab to be able to adjust based off more or less data coming from the original tab.

 

[igold]

How about this. The original information you supplied is on a sheet named "Original", starting with the header row in Cell A1 such as Cell A1.Value = "Assignment" (I deleted the row that said "Original Tab Information"). the newly completed Subtotal page will be added by the code and will be named "Summed".

subttl.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Assignment	Program	Number	Short Text	Budgeted	Planned	Commitments	Obligation	Actual Cost	Assigned Costs
2	CR1	NEW	1	BUILDING	$ 41,682.00	$		$	$	$
3	CR1	NEW	1	BUILDING	$ -	$		$	$	$
4	CR1	NEW	1	BUILDING	$ -	$ 20,002.18		$	$	$
5	CR2	WORN	2	LEVEL	$ 33,000.00	$		$ 1,564.53	$ 22,594.20	$ 24,158.73
6	CR2	WORN	2	LEVEL	$ -	$	$ 21.19	$	$
7	CR2	WORN	2	LEVEL	$ -	$	$ 347.65	$	$
8	CR3	EXPIRED	3	LAND	$ 7,118.21	$		$	$ 4,749.03	$ 4,749.03
9	CR3	EXPIRED	3	LAND	$ -	$		$	$
10	CR3	EXPIRED	3	LAND	$ -	$ 7,118.21		$	$ 2,367.20	$ 2,367.20
Original

Sub subTtls()
    
    Dim wsO As Worksheet: Set wsO = Worksheets("Original")
    Dim rng As Range, col, subt As Single
    Dim TopofSection As Long, lastrow As Long, c As Long, i As Long
    
    Application.ScreenUpdating = False
    wsO.Copy After:=wsO
    ActiveSheet.Name = "Summed"
    Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    With rng.Cells(rng.Rows.Count).Offset(1, 3)
        .Value = "TOTALS"
        .Interior.Color = RGB(180, 180, 180)
    End With
    For i = rng.Rows.Count To 1 Step -1
        With rng
            If i = 1 Then Exit For
            If .Cells(i) <> .Cells(i).Offset(-1) Then
                .Cells(i).EntireRow.Insert
                .Cells(i).Offset(, 3) = "TOTALS"
                .Cells(i).Offset(, 3).Interior.Color = RGB(180, 180, 180)
            End If
        End With
    Next
    col = Array("E", "F", "G", "H", "I", "J")
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For c = 0 To UBound(col)
        Do Until lastrow < 2
            TopofSection = Cells(lastrow, "B").End(xlUp).Row
            If Cells(lastrow - 1, 2) = "" Then TopofSection = lastrow
            subt = WorksheetFunction.Sum(Range(col(c) & TopofSection, col(c) & lastrow))
            Range(col(c) & lastrow).Offset(1, 0).Value = subt
            Range(col(c) & lastrow).Offset(1, 0).Interior.Color = RGB(180, 180, 180)
            lastrow = Cells(TopofSection, 2).End(xlUp).Row
        Loop
        lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Next
    Application.ScreenUpdating = True

End Sub