Add subtotal formula to empty cells

[transferxxx]

Can anybody pls help me to modify this code to make this work with
adjacent column(more than 1 coumn) i.e if my selection is A120 -
instead of A1:A20
(The macro works fine for a selection of A1:A20 but not A120)

Sub addsubtotalrange()
'

For Each NumRange In Selection.SpecialCells(xlConstants,
xlNumbers).Areas

SumAddr = NumRange.Address(False, False)
NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula =
"=SUBTOTAL(9," & SumAddr & ")"

Next NumRange
'
End Sub

 

[Joel]

the problem is simple

from:
NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula =
to:
NumRange.Offset(NumRange.Rows.Count, 0).

You only want the number of rows, not the total number of cells.

 

[transferxxx]

the problem is simple

from:
NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula =
to:
NumRange.Offset(NumRange.Rows.Count, 0).

You only want the number of rows, not the total number of cells.

It's not good as I don't get the correct result from my formula -
which should subtotal cells in corresponding column only.
pls help

thxs

 

[Joel]

It wasn't clear if you wanted one total or a seperate total for each column.
Try this

Sub addsubtotalrange()
'
For Each NumRange In _
Selection.SpecialCells(xlConstants, xlNumbers).Areas
For ColCount = 0 To (NumRange.Columns.Count - 1)
SumAddr = NumRange.Offset(0, ColCount). _
Resize(NumRange.Rows.Count, 1).Address(False, False)
NumRange.Offset(NumRange.Rows.Count, ColCount). _
Resize(1, 1).Formula = _
"=SUBTOTAL(9," & SumAddr & ")"
Next ColCount

Next NumRange

 

[GregR]

It's not good as I don't get the correct result from my formula -
which should subtotal cells in corresponding column only.
pls help

thxs- Hide quoted text -

- Show quoted text -

Your selection should still be A1:A20, but change resize(1,4)