Moving total cell

[Don W.]

Howdy,



Don't use Excel much but am building a very simple spreadsheet with five
columns, the last column contains dollar amounts. What I would like is a
formula in the column total that automatically moves the cell down one row
and re-totals the column when the user presses enter at the end of each row.



In other words, starting at row one column one the user would enter data
into 4 columns ending with a dollar amount in the 5th column. In the cell
below would be a total cell that moves down one and totals the cell(s) above
it when the user presses enter after entering a dollar amount in the last
cell.



Ideally the user would press enter when finished with each entry and the
active cell would move right instead of down until at column 5 at which
point the active cell would go back to column one. But I can deal without
that. The main question is the moving total cell. Assuming the above can be
done can I bring the cell to the left of the total cell (containing the
label for the total cell) with it? Keeping them together as-it-were.



The whole idea is to have a total of column 5 that requires no user input
regardless of the number of rows entered yet is always at the bottom of
column 5.



Whew!!



Did the above make sense? Can it be done?



Thanks much,



Don

 

[Paul Falla]

Dear Don
Please find below an example of some code which will do
most of what you want. The only problem is that it places
the running total in the top right cell of the range (eg
in F2). When first run it will pop up a message box asking
for the first range in the cell, and for a cell in the
column to be summed. You may be able to alter the code to
suit your needs.


Sub Insert_Rows_And_Sum()
Dim cell As Range, sumCell As Range,
comparisonValue
Dim topSumRow As Integer, sumColumn As Integer
'get ranges
On Error Resume Next
Set cell = Application.InputBox( _
prompt:="Select the first cell in
the ID column", _
Type:=8)
If cell Is Nothing Then Exit Sub
Set sumCell = Application.InputBox(

prompt:="Select any cell in the column to be summed", _
Type:=8)
If sumCell Is Nothing Then Exit Sub
'turn off error handling
On Error GoTo 0
'initialize values
comparisonValue = cell.Value
topSumRow = cell.Row
sumColumn = sumCell.Column
'loop until a blank cell is encountered
While Not IsEmpty(cell)
'check to see if value has changed

If cell.Value <> comparisonValue Then
'if the value has changed, insert two rows and a
sum formula
Range(cell.Offset(1, 0), _
cell.Offset(1, 0)).EntireRow.Insert
Cells(cell.Row + 1, sumColumn).Formula = _
"=Sum(" & Range(Cells(topSumRow,
sumColumn), _
Cells(cell.Row, _
sumColumn)).Address(False, False) & ")"

'update the cell to be checked, the comparison value, and
the
'top row number
Set cell = cell.Offset(3, 0)
comparisonValue = cell.Value
topSumRow = cell.Row
Else
'if the same value, set cell to the next cell
Set cell = cell.Offset(1, 0)
End If

Hope this helps

Paul Falla

 

[Don W.]

Thanks Paul, I'll give it a try.

Don

Dear Don
Please find below an example of some code which will do
most of what you want. The only problem is that it places
the running total in the top right cell of the range (eg
in F2). When first run it will pop up a message box asking
for the first range in the cell, and for a cell in the
column to be summed. You may be able to alter the code to
suit your needs.


Sub Insert_Rows_And_Sum()
Dim cell As Range, sumCell As Range,
comparisonValue
Dim topSumRow As Integer, sumColumn As Integer
'get ranges
On Error Resume Next
Set cell = Application.InputBox( _
prompt:="Select the first cell in
the ID column", _
Type:=8)
If cell Is Nothing Then Exit Sub
Set sumCell = Application.InputBox(

prompt:="Select any cell in the column to be summed", _
Type:=8)
If sumCell Is Nothing Then Exit Sub
'turn off error handling
On Error GoTo 0
'initialize values
comparisonValue = cell.Value
topSumRow = cell.Row
sumColumn = sumCell.Column
'loop until a blank cell is encountered
While Not IsEmpty(cell)
'check to see if value has changed

If cell.Value <> comparisonValue Then
'if the value has changed, insert two rows and a
sum formula
Range(cell.Offset(1, 0), _
cell.Offset(1, 0)).EntireRow.Insert
Cells(cell.Row + 1, sumColumn).Formula = _
"=Sum(" & Range(Cells(topSumRow,
sumColumn), _
Cells(cell.Row, _
sumColumn)).Address(False, False) & ")"

'update the cell to be checked, the comparison value, and
the
'top row number
Set cell = cell.Offset(3, 0)
comparisonValue = cell.Value
topSumRow = cell.Row
Else
'if the same value, set cell to the next cell
Set cell = cell.Offset(1, 0)
End If

Hope this helps

Paul Falla