Though it isn't documented anywhere, so far as I know, I had to solve a similar problem a few weeks ago. The VBA function below inserts sums into a row, given a rectangular range of cells. For each column in the range, the bottom cell gets a formula that sums the cells above it, ecept for the first column, which gets the string specified in the second argument, which is assumed to be a label for the last row.
CODE
Public Sub InsertColumnSums( _
prngInputRange As Range, _
pstrGrandTotalsLbl As String)
' ============================================================================
'
' Name: InsertColumnSums
'
' Synopsis: Construct and insert formulas to sum the cells in each
' coloumn of an input range, prngInputRange, and enter the
' label, pstrGrandTotalsLbl, to the cell in column one.
'
' Arguments: prngInputRange = A Range object that represents the
' area in the worksheet where the
' summary is to be recorded.
' See Notes.
'
' pstrGrandTotalsLbl = A String containing the label to
' apply to the grand totals row. The
' first column is assumed to contain
' row labels.
'
' Returns: Nothing. All changes happen in range prngInputRange.
'
' Notes: The first column is assumed to contain labels. Accordingly,
' the contents of string pstrGrandTotalsLbl become the value
' of the first cell in the last row. The remaining cells get
' formulas that return the sum of the cells in the first row
' to the next to last row, inclusive.
'
' IMPORTANT: When manually entering formulas for range sums,
' standard practice is to extend the range one row
' above, and one below, the desired range, and to
' ensure that the two end cells contain only text,
' or are left blank. The formulas generated and
' entered by this function omit these customary
' blanks rows, unless they happen to be blank, or
' contain text.
'
' Author: David A. Gray, Chief Wizard
' Simple Soft Services, Inc., d/b/a WizardWrx
' http://www.wizardwrx.com/
'
' Copyright: 2008, Simple Soft Services, Inc., d/b/a WizardWrx
' All rights reserved world wide.
'
' References:
'
' Created: Wednesday, 27 August 2008 and Thursday, 28 August 2008
'
' Maintenance History
'
' Date Version Author Synopsis
' ---------- ------- ------ --------------------------------------------------
' 2008/08/28 1.00 DAG/WW Initial version created.
' ============================================================================
Const FROMULA_TEMPLATE As String = "=Sum($$TOP$$:$$BOT$$)"
Const TOP_TOKEN As String = "$$TOP$$"
Const BOT_TOKEN As String = "$$BOT$$"
Const RANGE_FIRST_DETAIL_COL As Integer = 2
On Error GoTo InsertColumnSums_Err
Dim wwException As WWXLAppExceptions
Set wwException = New WWXLAppExceptions
wwException.ErrorListSheet = RANGELIB_MSG_WKS_NM
Dim lngLastRowIndex As Long
lngLastRowIndex = prngInputRange.Rows.Count
Dim lngLastDetailRowIndex As Long
lngLastDetailRowIndex = lngLastRowIndex - 1
Dim intLastColIndex As Integer
intLastColIndex = prngInputRange.Columns.Count
Dim intCurrCol As Integer
prngInputRange.Cells( _
lngLastRowIndex, _
RANGE_ORIGIN_CELL_INDEX) _
= pstrGrandTotalsLbl
For intCurrCol = RANGE_FIRST_DETAIL_COL To intLastColIndex
Dim strAddressTop As String
Dim strAddressBot As String
Dim strFormula As String
strAddressTop = prngInputRange.Cells( _
RANGE_ORIGIN_CELL_INDEX, _
intCurrCol).Address
strAddressBot = prngInputRange.Cells( _
lngLastDetailRowIndex, _
intCurrCol).Address
strFormula = Replace( _
FROMULA_TEMPLATE, _
TOP_TOKEN, _
strAddressTop)
strFormula = Replace( _
strFormula, _
BOT_TOKEN, _
strAddressBot)
prngInputRange.Cells( _
lngLastRowIndex, _
intCurrCol) = strFormula
Next intCurrCol
InsertColumnSums_End:
Exit Sub
InsertColumnSums_Err:
wwException.Show "InsertColumnSums"
Err.Raise wwException.Number, _
wwException.Source, _
wwException.Description
Exit Sub ' This is unreachable, but I leave it, for tiger proofing.
End Sub
You enter a formula into a cell exactly the same way that you enter literals; you set the cell's value.
For example, to enter a formula that computes the sum of the values in cells A1 through A4, you enter the following into, for example, cell A5.
=SUM(A1:A4)
HTH.
| 