Copy Subtotals

[fddekker]

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.

 

[fddekker]

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

 

[fddekker]

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