Copy Subtotals

fddekker

Board Regular
Joined
Jun 30, 2008
Messages
86
Office Version
  1. 365
Platform
  1. Windows
Below is a very basic extract from a large worksheet:

_________________A_____B__________________C_____D
1_EXPENSE______________JAN________________FEB___MAR
2_Salaries_______________100________________130__125
3_Benefits_______________120________________150__145
4_SALARIES & BENFITS____=SUBTOTAL(9,B2:B3)____280__270
5_Materials______________60__________________40___55
6_Supplies_______________80_________________120__95
7_MATERIALS & SUPPLIES__=SUBTOTAL(9,B5:B6)____160__150
8_GRAND TOTAL__________=SUBTOTAL(9,B2:B7)____440__420

I would like to copy the subtotals from column B (dynamic - not always column B) to columns C and D (also dynamic and could be one or several columns) to replace the hard coded totals that currently appears. I do not wish to undo and redo subtotals, as there are several layers and additional columns are added at different stages. The length of data is always the same for all columns.

I have played around with:
Go TO, visible cells only, .... then when only the subtotals are displayed, COPY but are unable to find anything like PASTE TO VISIBLE CELLS ONLY that works.

I also tried to find subtotals within a range [rCell.Formula, "SUBTOTAL"] and got it to work by using OFFSET, but are then limited to only one column.

Any advice would be appreciated.
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Highlighting column B, I am able to copy the formula to column C with this macro, but the formula does not update the relative addresses. Any help?

Sub MoveSubtotals()
Dim rOriginal As Range
Dim rng As Range
Dim iColumn As Integer
Dim iOffset As Integer

iColumn = ActiveCell.Column
iOffset = 1
Set rng = Intersect(Selection.CurrentRegion, Columns(iColumn))
For Each rOriginal In rng
If InStr(rOriginal.Formula, "SUBTOTAL") Then
rOriginal.Offset(0, iOffset).Formula = rOriginal.Formula
End If
Next
End Sub
 
Upvote 0
Managed to finally figured this one out. In case anybody else need it:

Sub CopySubtotals()
Dim rCell As Range
Dim rng As Range
Dim iCol As Integer

iCol = ActiveCell.Column
iOffset = 1
Set rng = Intersect(Selection.CurrentRegion, Columns(iCol))
For Each rCell In rng
If InStr(rCell.Formula, "SUBTOTAL") Then
rCell.Copy
ActiveSheet.Paste Destination:=rCell.Offset(0, iOffset)
Application.CutCopyMode = False
End If
Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,101
Members
448,548
Latest member
harryls

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