VBA Insert Row and total columns based on criteria in column A

[JayCS]

OK, I'm need help. I took on a project over my head and I am close to finishing. I just need help on one thing. My project involves Access generating a Cross-Tab query and exporting to Excel. Once it gets to Excel, I need to insert a row and subtotal based on name in column A:

For Example:

Name	XXX	XXX	Week 1	Week 2	Week 3	Week 4	Week 5
Doe, John			40	50	32	25	11
Doe, John			17	25	13	10	23
Smith, Larry			32	45	15	22	14
Smith, Larry			11	14	22	11	7

<tbody>
</tbody>

Final product would look like:

Name	XXX	XXX	Week 1	Week 2	Week 3	Week 4	Week 5
Doe, John			40	50	32	25	11
Doe, John			17	25	13	10	23
Subtotal			57	75	45	35	34
Smith, Larry			32	45	15	22	14
Smith, Larry			11	14	22	11	7
Subtotal			43	59	37	33	21

<tbody>
</tbody>

I need to insert a row at the end of Doe, John and total the columns that have numbers. Actually, I need to insert a row at the end of every person and add the columns that have numbers. The following week, the spreadsheet will have an extra column "Week 6" and this will go on to infinity...theoretically. Can someone help me with the VBA to insert a subtotal row for each individual and to sum the columns where there are numbers. In my actual spreadsheet, Column "A" is the name and the numbers columns start at column "D" and go out from there.

Any help would be much appreciated.

Thanks,

Jay

 

[sheetspread]

Excel has a subtotal in the data ribbon that will do this

 

[Mike LH]

Hi,

Select your table including the headers then

View tab | Outline group | Subtotal

It's now fairly intuitive bit in the first dropdown select 'Name'
In the second select 'Sum'
Check 'Summary below data' and click OK and you're done.

 

[JayCS]

Hi,

Select your table including the headers then

View tab | Outline group | Subtotal

It's now fairly intuitive bit in the first dropdown select 'Name'
In the second select 'Sum'
Check 'Summary below data' and click OK and you're done.

Thanks for the help. Here is my problem. I have no problem subtotaling myself but I am developing this for someone else and wanted to create a macro that would do this. Every week, they will get a new worksheet that will continue to grow. Currently there are 42 columns that have to be subtotaled. So, to use this method, the end user would have to checkmark 42 fields this week, 43 next week, and so on. I found some VBA online that adds two rows and subtotals column B and C but the script was static. I could manually manipulate the script to include all the columns I need but in 1 weeek, that script will be outdated.

Does anyone have scripting that will accomplish this?

Thanks,

Jay

 

[sheetspread]

Try:

Sub subtotalmacro()
Range("A1:H" & Cells(Rows.Count, 1).End(xlUp).Row).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6, 7, _
8), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Columns("A:A").EntireColumn.AutoFit
End Sub

on your example above, add more column numbers to the array as you like

 

[sheetspread]

It sounds like you should be exporting the query without transform/pivot and then letting Excel do it for you while subtotaling (i.e. a pivot table)

 

[JayCS]

The VBA posted worked but I noticed the range was from Column "D" through Column "H". This will continue to grow every week. Is there any way to change the code to say from Column "D" to the last column that contains numbers?

 

[sheetspread]

This?

Sub subtotalmacro1()
Dim i%, lc%, colarray()
lc = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim colarray(1 To lc - 3)
For i = 4 To lc
colarray(i - 3) = i
Next
Range("A1:" & Cells(Cells(Rows.Count, 1).End(xlUp).Row, lc).Address).Subtotal GroupBy:=1, Function:=xlSum, _
TotalList:=colarray, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Columns("A:A").EntireColumn.AutoFit
End Sub

 

[sheetspread]

Actually you don't need the loop (got this from Rory and Nate)

Sub subtotalmacro3()
Dim lc%
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Range("A1:" & Cells(Cells(Rows.Count, 1).End(xlUp).Row, lc).Address).Subtotal GroupBy:=1, Function:=xlSum, _
TotalList:=Application.Transpose(Evaluate("INDEX(ROW(4:" & lc & "),,0)")), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Columns("A:A").EntireColumn.AutoFit
End Sub