Simply-fly Subtotal and add some condition

[sachin483]

how to simply-fly this macro

i have recorded the macro while doing subtotal i want to simply-fly the process


1.Sorting should not be of specific range , it should be for full column range rows in data can increase or decrease ,column sorting order is ok .

2. There are 3 subtotal - for 1st subtotal only Grand Total must be there in the end for other 2 not required - how to remove

3. Color for all the 3 subtotal can be done

4.Subtotal is not delete after last subtotal

Sub subtotal()
'
' subtotal Macro
'

'
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("12").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("12").Sort.SortFields.Add Key:=Range("B2:B80"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("12").Sort.SortFields.Add Key:=Range("D2:D80"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("12").Sort.SortFields.Add Key:=Range("F2:F80"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("12").Sort.SortFields.Add Key:=Range("H2:H80"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("12").Sort
        .SetRange Range("A1:W80")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(10, 11, 12 _
        , 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=True
    Selection.Copy
    Application.Run "ASAPRunProc268"
    Application.CutCopyMode = False
    Selection.RemoveSubtotal
    Selection.subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(10, 11, 12 _
        , 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=True
    Selection.Copy
    Application.Run "ASAPRunProc268"
    Application.CutCopyMode = False
    Selection.RemoveSubtotal
    Selection.subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(10, 11, 12 _
        , 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=True
    Selection.Copy
    Application.Run "ASAPRunProc268"
    Application.CutCopyMode = False
    Selection.RemoveSubtotal
    Range("A1").Select
End Sub

 

[sachin483]

Can someone help me out

 

[Max1616]

I think it would be easier for others to help you out if you just gave us a list of actions you wanted a macro for. For example:

make a macro that does this
1. Sort Columns A:W in ascending order buy column B
2. Sort Columns A:W in ascending order by column D
3. Sort Columns A:W in ascending order by column F
4. Sort Columns A:W in ascending order by column H
5. In column A indicate a subtotal at the bottom of the sheet
6. In column B indicate a subtotal at the bottom of the sheet
7. In column A indicate a subtotal at the bottom of the sheet
8. Color the Subtotal cells yellow

I don't think this is what you want. But something along these lines will help us formulate a Macro to best suit your needs.

Sincerely,
Max

 

[sachin483]

please find enclosed sample for which i do sorting and subtotal in data sheet and the result sheet, After sorting and subtotal i colored all the totals and then concatenate with some character for reference purpose and put them in column number (I) then do the paste special

basic data

	SORTING 1	SUBTOTAL 1	SORTING 2	SUBTOTAL 2	SORTING 3	SUBTOTAL 3	SORTING 4
DD	ZCD	ZDSCR	RCD	RDSCR	ACD	ADSCR	TCD	TDSCR	NMR	APR	MAY	JUN	JUL	AUG	SEP	OCT	NOV	DEC	JAN	FEB	MAR	TOTAL
XX	XX01	DUMMY1	BRX18	DUMMY8	BX01	DUMMY1	XX301	DUMMY1	10	204.58	193.27	195.53	197.80	200.06	206.85	195.53	206.85	206.85	202.32	204.58	195.53	2409.76
XX	XX01	DUMMY1	BRX18	DUMMY8	BX02	DUMMY2	XX302	DUMMY2	1	28.58	27.62	27.81	28.00	28.20	28.77	27.81	28.77	28.77	28.39	28.58	27.84	339.12
XX	XX01	DUMMY1	BRX22	DUMMY12	BX03	DUMMY3	XX303	DUMMY3	2	32.43	31.24	31.48	31.72	31.95	32.67	31.48	32.67	32.67	32.19	32.43	31.49	384.43
XX	XX01	DUMMY1	BRX22	DUMMY12	BX03	DUMMY3	XX304	DUMMY4	2	33.25	32.00	32.26	32.50	32.74	33.49	32.26	33.49	33.49	32.99	33.25	32.25	393.97
XX	XX01	DUMMY1	BRX22	DUMMY12	BX150	DUMMY16	XX305	DUMMY5	2	25.48	24.71	24.86	25.01	25.17	25.64	24.86	25.64	25.64	25.33	25.48	24.86	302.69
XX	XX01	DUMMY1	BRX22	DUMMY12	BX150	DUMMY16	XX306	DUMMY6	1	22.26	21.67	21.79	21.90	22.02	22.37	21.79	22.37	22.37	22.14	22.25	21.77	264.72
XX	XX01	DUMMY1	BRX22	DUMMY12	BX04	DUMMY4	XX307	DUMMY7	1	19.69	19.25	19.34	19.42	19.51	19.77	19.34	19.77	19.77	19.60	19.69	19.35	234.50
XX	XX01	DUMMY1	BRX22	DUMMY12	BX04	DUMMY4	XX308	DUMMY8	3	49.29	47.11	47.54	47.98	48.42	49.73	47.54	49.73	49.73	48.85	49.29	47.53	582.74
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX309	DUMMY9	1	33.56	32.30	32.55	32.81	33.05	33.81	32.55	33.81	33.81	33.31	33.56	32.58	397.67
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX310	DUMMY10	2	37.92	36.41	36.71	37.02	37.32	38.22	36.71	38.22	38.22	37.62	37.92	36.73	449.03
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX311	DUMMY11	1	25.57	24.79	24.94	25.10	25.26	25.73	24.94	25.73	25.73	25.42	25.57	24.96	303.74
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX312	DUMMY12	2	43.17	41.35	41.71	42.08	42.44	43.53	41.71	43.53	43.53	42.80	43.17	41.70	510.71
XX	XX01	DUMMY1	BRX13	DUMMY3	BX06	DUMMY6	XX313	DUMMY13	1	22.80	22.17	22.30	22.42	22.55	22.92	22.30	22.92	22.92	22.68	22.80	22.32	271.08
XX	XX01	DUMMY1	BRX13	DUMMY3	BX06	DUMMY6	XX314	DUMMY14	2	31.47	30.34	30.56	30.79	31.01	31.69	30.56	31.69	31.69	31.24	31.47	30.56	373.08
XX	XX02	DUMMY2	BRX19	DUMMY9	BX07	DUMMY7	XX315	DUMMY15	1	22.17	21.59	21.70	21.82	21.93	22.29	21.70	22.29	22.29	22.05	22.17	21.68	263.69

<colgroup><col><col><col><col><col><col><col><col><col><col><col span="12"><col></colgroup><tbody>
</tbody>

result data

DD	ZCD	ZDSCR	RCD	RDSCR	ACD	ADSCR	TCD	TDSCR	NMR	APR	MAY	JUN	JUL	AUG	SEP	OCT	NOV	DEC	JAN	FEB	MAR	TOTAL
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX309	DUMMY9	1	33.56	32.30	32.55	32.81	33.05	33.81	32.55	33.81	33.81	33.31	33.56	32.58	397.67
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX310	DUMMY10	2	37.92	36.41	36.71	37.02	37.32	38.22	36.71	38.22	38.22	37.62	37.92	36.73	449.03
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX311	DUMMY11	1	25.57	24.79	24.94	25.10	25.26	25.73	24.94	25.73	25.73	25.42	25.57	24.96	303.74
XX	XX01	DUMMY1	BRX13	DUMMY3	BX05	DUMMY5	XX312	DUMMY12	2	43.17	41.35	41.71	42.08	42.44	43.53	41.71	43.53	43.53	42.80	43.17	41.70	510.71
XX						DUMMY5 Total		AR_DUMMY5 Total	6	140.22	134.85	135.91	137.00	138.07	141.29	135.91	141.29	141.29	139.14	140.21	135.97	1661.15
XX	XX01	DUMMY1	BRX13	DUMMY3	BX06	DUMMY6	XX313	DUMMY13	1	22.80	22.17	22.30	22.42	22.55	22.92	22.30	22.92	22.92	22.68	22.80	22.32	271.08
XX	XX01	DUMMY1	BRX13	DUMMY3	BX06	DUMMY6	XX314	DUMMY14	2	31.47	30.34	30.56	30.79	31.01	31.69	30.56	31.69	31.69	31.24	31.47	30.56	373.08
XX	XX01	DUMMY1	BRX13	DUMMY3	BX06	DUMMY6	XX404	DUMMY104	1	18.77	18.39	18.46	18.54	18.62	18.85	18.46	18.85	18.85	18.69	18.77	18.49	223.72
XX						DUMMY6 Total		AR_DUMMY6 Total	4	73.04	70.90	71.32	71.75	72.18	73.45	71.32	73.45	73.45	72.61	73.03	71.37	867.88
XX				DUMMY3 Total				RE_DUMMY3 Total	10	213.25	205.75	207.23	208.75	210.25	214.74	207.23	214.74	214.74	211.75	213.25	207.34	2529.02
XX	XX01	DUMMY1	BRX18	DUMMY8	BX01	DUMMY1	XX301	DUMMY1	10	204.58	193.27	195.53	197.80	200.06	206.85	195.53	206.85	206.85	202.32	204.58	195.53	2409.76
XX						DUMMY1 Total		AR_DUMMY1 Total	10	204.58	193.27	195.53	197.80	200.06	206.85	195.53	206.85	206.85	202.32	204.58	195.53	2409.76
XX	XX01	DUMMY1	BRX18	DUMMY8	BX02	DUMMY2	XX302	DUMMY2	1	28.58	27.62	27.81	28.00	28.20	28.77	27.81	28.77	28.77	28.39	28.58	27.84	339.12
XX						DUMMY2 Total		AR_DUMMY2 Total	1	28.58	27.62	27.81	28.00	28.20	28.77	27.81	28.77	28.77	28.39	28.58	27.84	339.12
XX	XX01	DUMMY1	BRX18	DUMMY8	BX45	DUMMY45	XX413	DUMMY110	3	71.81	68.30	69.00	69.70	70.40	72.50	69.00	72.50	72.50	71.10	71.81	69.00	847.62
XX						DUMMY45 Total		AR_DUMMY45 Total	3	71.81	68.30	69.00	69.70	70.40	72.50	69.00	72.50	72.50	71.10	71.81	69.00	847.62
XX	XX01	DUMMY1	BRX18	DUMMY8	BX46	DUMMY46	XX414	DUMMY111	3	65.63	62.48	63.11	63.74	64.37	66.25	63.11	66.25	66.25	65.00	65.63	63.12	774.95
XX						DUMMY46 Total		AR_DUMMY46 Total	3	65.63	62.48	63.11	63.74	64.37	66.25	63.11	66.25	66.25	65.00	65.63	63.12	774.95
XX				DUMMY8 Total				RE_DUMMY8 Total	17	370.59	351.67	355.46	359.24	363.02	374.38	355.46	374.38	374.38	366.80	370.59	355.50	4371.45
XX	XX01	DUMMY1	BRX22	DUMMY12	BX03	DUMMY3	XX303	DUMMY3	2	32.43	31.24	31.48	31.72	31.95	32.67	31.48	32.67	32.67	32.19	32.43	31.49	384.43
XX	XX01	DUMMY1	BRX22	DUMMY12	BX03	DUMMY3	XX304	DUMMY4	2	33.25	32.00	32.26	32.50	32.74	33.49	32.26	33.49	33.49	32.99	33.25	32.25	393.97
XX	XX01	DUMMY1	BRX22	DUMMY12	BX03	DUMMY3	XX421	DUMMY118	1	17.48	17.17	17.24	17.30	17.36	17.54	17.24	17.54	17.54	17.42	17.48	17.25	208.56
XX						DUMMY3 Total		AR_DUMMY3 Total	5	83.16	80.42	80.97	81.52	82.06	83.70	80.97	83.70	83.70	82.60	83.16	80.99	986.95
XX	XX01	DUMMY1	BRX22	DUMMY12	BX04	DUMMY4	XX307	DUMMY7	1	19.69	19.25	19.34	19.42	19.51	19.77	19.34	19.77	19.77	19.60	19.69	19.35	234.50
XX	XX01	DUMMY1	BRX22	DUMMY12	BX04	DUMMY4	XX308	DUMMY8	3	49.29	47.11	47.54	47.98	48.42	49.73	47.54	49.73	49.73	48.85	49.29	47.53	582.74
XX						DUMMY4 Total		AR_DUMMY4 Total	4	68.97	66.36	66.88	67.41	67.93	69.50	66.88	69.50	69.50	68.45	68.97	66.88	817.25
XX	XX01	DUMMY1	BRX22	DUMMY12	BX150	DUMMY16	XX305	DUMMY5	2	25.48	24.71	24.86	25.01	25.17	25.64	24.86	25.64	25.64	25.33	25.48	24.86	302.69
XX	XX01	DUMMY1	BRX22	DUMMY12	BX150	DUMMY16	XX306	DUMMY6	1	22.26	21.67	21.79	21.90	22.02	22.37	21.79	22.37	22.37	22.14	22.25	21.77	264.72
XX	XX01	DUMMY1	BRX22	DUMMY12	BX150	DUMMY16	XX395	DUMMY95	1	21.08	20.56	20.66	20.76	20.87	21.18	20.66	21.18	21.18	20.97	21.08	20.68	250.85
XX						DUMMY16 Total		AR_DUMMY16 Total	4	68.82	66.93	67.31	67.68	68.06	69.20	67.31	69.20	69.20	68.44	68.81	67.32	818.26
XX				DUMMY12 Total				RE_DUMMY12 Total	13	220.95	213.71	215.16	216.60	218.05	222.40	215.16	222.40	222.40	219.50	220.94	215.19	2622.46
XX		DUMMY1 Total						ZR_DUMMY1 Total	40	804.79	771.12	777.85	784.59	791.32	811.52	777.85	811.52	811.52	798.05	804.78	778.02	9522.93

<colgroup><col><col><col><col><col><col><col><col><col><col><col span="12"><col></colgroup><tbody>
</tbody>

 

[Max1616]

Run this, assuming your column headers are in row 1 and not row 2:

Sub sachin483()
Dim lrow As Long
Dim i As Long
Dim Sub1 As String
Dim Sub2 As String
Dim Sub3 As String
Dim ORow1 As Long
Dim ORow2 As Long
Dim ORow3 As Long


lrow = Cells(Rows.Count, 1).End(xlUp).Row

Range("H2:H" & lrow).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes
Range("F2:F" & lrow).Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlYes
Range("D2:D" & lrow).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes
Range("B2:B" & lrow).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
ORow1 = 0

'Subtotal 1
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Sub1 = Cells(i + 1, 7)
    If i = lrow Then Sub1 = Cells(i, 7)
    If Cells(i + 1, 7) = "" Then Sub1 = Cells(i, 7)
    
    If Cells(i - 1, 7) = Sub1 Then
        GoTo Nexti1
    Else

        If ORow1 = 0 Then ORow1 = lrow + 2
    

        Cells(i, 1).EntireRow.Insert
        
        
        Cells(ORow1, 1) = Cells(i - 1, 1)
        Cells(ORow1, 7) = Sub1 & " Total"
        Cells(ORow1, 9) = "AR_" & Sub1 & " Total"
    
        Cells(ORow1, 10) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 10), Cells(i + 1, 10)))
        Cells(ORow1, 11) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 11), Cells(i + 1, 11)))
        Cells(ORow1, 12) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 12), Cells(i + 1, 12)))
        Cells(ORow1, 13) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 13), Cells(i + 1, 13)))
        Cells(ORow1, 14) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 14), Cells(i + 1, 14)))
        Cells(ORow1, 15) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 15), Cells(i + 1, 15)))
        Cells(ORow1, 16) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 16), Cells(i + 1, 16)))
        Cells(ORow1, 17) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 17), Cells(i + 1, 17)))
        Cells(ORow1, 18) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 18), Cells(i + 1, 18)))
        Cells(ORow1, 19) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 19), Cells(i + 1, 19)))
        Cells(ORow1, 20) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 20), Cells(i + 1, 20)))
        Cells(ORow1, 21) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 21), Cells(i + 1, 21)))
        Cells(ORow1, 22) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 22), Cells(i + 1, 22)))
        Cells(ORow1, 23) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 23), Cells(i + 1, 23)))
    
        Range(Cells(ORow1, 7), Cells(ORow1, 23)).Interior.ColorIndex = 6
        Cells(ORow1, 7).Font.Bold = True
        
        ORow1 = i + 1
        
        
        If i = 2 Then Rows(2).Delete
        If i = 2 Then Cells(1, 2).End(xlDown).Offset(1, -1) = "XX"
    End If
   
Nexti1:
Next i

'Subtotal 2
lrow = Cells(Rows.Count, 7).End(xlUp).Row

Sub2 = Cells(lrow - 1, 5)
ORow2 = lrow + 1

For i = lrow To 1 Step -1
    If Cells(i, 5) <> "" And Cells(i, 5) <> Sub2 Then
        If i = 1 Then Rows(1).Insert
        If i = 1 Then ORow2 = ORow2 + 1
        
        Cells(ORow2, 1) = "XX"
        Cells(ORow2, 5) = Sub2 & " Total"
        Cells(ORow2, 9) = "RE_" & Sub2 & " Total"
            
         Cells(ORow2, 10) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 10), Cells(ORow2 - 2,  10)))
        Cells(ORow2, 11) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 11), Cells(ORow2 - 2, 11)))
         Cells(ORow2, 12) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 12), Cells(ORow2 - 2,  12)))
        Cells(ORow2, 13) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 13), Cells(ORow2 - 2, 13)))
         Cells(ORow2, 14) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 14), Cells(ORow2 - 2,  14)))
        Cells(ORow2, 15) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 15), Cells(ORow2 - 2, 15)))
         Cells(ORow2, 16) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 16), Cells(ORow2 - 2,  16)))
        Cells(ORow2, 17) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 17), Cells(ORow2 - 2, 17)))
         Cells(ORow2, 18) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 18), Cells(ORow2 - 2,  18)))
        Cells(ORow2, 19) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 19), Cells(ORow2 - 2, 19)))
         Cells(ORow2, 20) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 20), Cells(ORow2 - 2,  20)))
        Cells(ORow2, 21) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 21), Cells(ORow2 - 2, 21)))
         Cells(ORow2, 22) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5),  Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 22), Cells(ORow2 - 2,  22)))
        Cells(ORow2, 23) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)),  Sub2, Range(Cells(i + 2, 23), Cells(ORow2 - 2, 23)))
            
        Range(Cells(ORow2, 5), Cells(ORow2, 23)).Interior.ColorIndex = 17
            
            
            
        If i = 1 Then
            Cells(ORow2, 5).Font.Bold = True
            Rows(1).Delete
        Else
            Cells(ORow2, 5).Font.Bold = True
            Cells(i + 2, 1).EntireRow.Insert
        End If
        
        Sub2 = Cells(i, 5)
        ORow2 = i + 2
        
        
        
    End If
Next i



lrow = Cells(Rows.Count, 5).End(xlUp).Row

Sub3 = Cells(lrow - 2, 3)
ORow3 = lrow + 1

For i = lrow To 1 Step -1
    If Cells(i, 3) <> "" And Cells(i, 3) <> Sub3 Then
        
            If i = 1 Then Rows(1).Insert
            If i = 1 Then ORow3 = ORow3 + 1
        
            Cells(ORow3, 1) = "XX"
            Cells(ORow3, 3) = Sub3 & " Total"
            Cells(ORow3, 9) = "ZR_" & Sub3 & " Total"
            
             Cells(ORow3, 10) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 10), Cells(ORow3 - 2,  10)))
            Cells(ORow3, 11) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 11), Cells(ORow3 - 2, 11)))
             Cells(ORow3, 12) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 12), Cells(ORow3 - 2,  12)))
            Cells(ORow3, 13) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 13), Cells(ORow3 - 2, 13)))
             Cells(ORow3, 14) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 14), Cells(ORow3 - 2,  14)))
            Cells(ORow3, 15) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 15), Cells(ORow3 - 2, 15)))
             Cells(ORow3, 16) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 16), Cells(ORow3 - 2,  16)))
            Cells(ORow3, 17) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 17), Cells(ORow3 - 2, 17)))
             Cells(ORow3, 18) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 18), Cells(ORow3 - 2,  18)))
            Cells(ORow3, 19) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 19), Cells(ORow3 - 2, 19)))
             Cells(ORow3, 20) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 20), Cells(ORow3 - 2,  20)))
            Cells(ORow3, 21) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 21), Cells(ORow3 - 2, 21)))
             Cells(ORow3, 22) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3),  Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 22), Cells(ORow3 - 2,  22)))
            Cells(ORow3, 23) =  WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)),  Sub3, Range(Cells(i + 2, 23), Cells(ORow3 - 2, 23)))
            
            Range(Cells(ORow3, 3), Cells(ORow3, 23)).Interior.ColorIndex = 40
            Cells(ORow3, 3).Font.Bold = True
            
            
            
        If i = 1 Then
        Rows(1).Delete
        Else
        Cells(i + 3, 1).EntireRow.Insert
        End If
        
        Sub3 = Cells(i, 3)
        ORow3 = i + 3
        
    End If

Next i



End Sub

I can't really think of a better way to do this outside of writing 3 separate loops. Which means that this could take a while to run depending on how much data you have. But I am able to recreate your 'result' tab that you provided from the data. (Just remember to delete the first row)

Please let me know if this worked!

Sincerely,
Max