Auto-sum (without SendKeys)

[Guest]

I have about 50,000 entries (dollar amounts) in Column A. At various (a
couple of thousand) rows, there are empty cells. If I position my cell at
the very bottom (the last empty cell) and I click the auto-sum icon, that
will (correctly) sum the values until the next empty cell (above) is reached.
However, the "record macro" sees that action as either an absolute cell
address (which I don't want) or a specific number of rows (relative address)
which I don't want, either, because the addresses and number of rows change
throughout Column A. So, that macro won't work if I want it to repeat until
it reaches A1.

So, I tried all of these (to represent Alt-equals and then Enter)

SendKeys "%(=){ENTER}"

SendKeys "%={ENTER}"

SendKeys "%(=)"
SendKeys "{ENTER}"

SendKeys "%="
SendKeys "{ENTER}"

but none of 'em worked ... it seemed like Excel didn't even recognize the
SendKeys command ... I mean, nothing happened.

How can I tell my macro to autosum without specifying specific cell
addresses or number of rows? I suspect that there's a simple answer but I
just can't seem to get my head around it.

Dan

 

[Guest]

The following two functions are required. This is the fastest performing
subtotal code I've been able to come up with, perhaps someone else will put
it to shame.

Requirements:
1) You must manually or using code make a selection that will be processed
BEFORE running the programs.

2) You must include one extra row at the bottom to accommodate the last entry.

3) Your data must not include blank cells other than those in which the
subtotal and adjoining spacer rows are located (i.e. you can have two blank
rows in between each cluster of data to be subtotaled, but each cluster of
data cannot have any blanks within them).

4) You must run each column one at a time, which is easily done in code.

Here are the functions, copy into a standard code module, make your
selection, and run the "ValueSubTotal" program - test on a copy first to be
sure it works okay on your data. You will need to correct the code for line
wrapping after you copy it into a module:

Public Function ValueSubTotal()
'CALCULATE SUBTOTALS IN A COLUMN WHENEVER A BLANK CELL IS FOUND
Dim rCell As Range
Dim sADD As String
Application.ScreenUpdating = False
ActiveSheet.DisplayAutomaticPageBreaks = False
Application.Calculation = xlCalculationManual
For Each rCell In Selection
If rCell.Row > 1 Then
If rCell.FormulaR1C1 = "" _
And Not UCase(rCell.Offset(-1, 0).FormulaR1C1) Like "=SUBTOTAL(*" _
And Application.WorksheetFunction.IsNumber(rCell.Offset(-1, 0).Value) _
And rCell.Offset(-1, 0).FormulaR1C1 <> "" Then
'And Not rCell.Offset(-1, 0).Borders(xlEdgeBottom).LineStyle =
xlContinuous
sADD = SumString(CStr(rCell.Address))
'rCell.Value = Application.Sum(Range(sAdd)) 'hard-written totals
rCell.Formula = "=SUBTOTAL(9," & sADD & ")"
rCell.Borders(xlEdgeTop).LineStyle = xlContinuous
rCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
End If
End If
Next rCell
Application.ScreenUpdating = True
ActiveSheet.DisplayAutomaticPageBreaks = True
Application.Calculation = xlCalculationAutomatic
End Function

Private Function SumString(argAddress As String) As String
'RETURN A RANGE ADDRESS FOR ALL CONTIGUOUS CELLS IN THE CURRENT COLUMN
SumString =
Application.Intersect(Range(Range(argAddress).CurrentRegion.Address),
Range(Range(Cells(Range(argAddress).Row,
Range(argAddress).Column).Address).EntireColumn.Address)).Resize(Range(argAddress).CurrentRegion.Rows.Count - 1, 1).Address
End Function

HTH/

 

[Rowan Drummond]

Assuming your data starts in cell A2 try something like:

Sub AddTots()
Dim SRow As Long
Dim ERow As Long
Dim FRow As Long

FRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
SRow = 2
Do Until ERow = FRow
If Cells(SRow + 1, 1).Value <> Empty Then
ERow = Cells(SRow, 1).End(xlDown).Row + 1
Cells(ERow, 1).FormulaR1C1 = _
"=SUM(R[" & SRow - ERow & "]C:R[-1]C)"
SRow = ERow + 1
Else
Cells(SRow + 1, 1).FormulaR1C1 = "=SUM(R[-1]C:R[-1]C)"
SRow = SRow + 2
End If
Loop
End Sub

Hope this helps
Rowan

 

[Guest]

To Quartz and Rowan:

Wow!

Thanks. Dan

 

[Rowan Drummond]

You're welcome.