elnicca
07-05-2013, 07:40 AM
Hi guys,
So this is my first post though I have been reading you for a while.
I wanted to share with you a code I created a while ago.
It works well but there is one thing pending to make it perfect. Maybe you can help me achieve this.
What this does is basically insert a SUM (below selected cell) and sets the range with the consecutive rows above the cell selected. Then (below sum function) it checks the difference between the selected cell and the new calculated SUM.
What I need help with is adding a loop function so if the sum() does not equal the selected cell then the range gets extended one cell up untill that value is reached or top of the page is reached.
The code I have today:
Sub AutoFootv2()
'
' AutoFootv2 Macro
' redo SUM, Compares against selected cell
' pending: extend sum range if selected cell and redone SUM are not equal
'
Dim rngStart As Range
Dim rng As Range
Set rngStart = ActiveCell
Set rng = Range(ActiveCell.Offset(-1, 0), ActiveCell.End(xlUp))
If ActiveCell.Offset(1, -1).Value = "" And ActiveCell.Offset(2, -1).Value = "" _
Then
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rngStart.Select
ActiveCell.Offset(1, 0).Formula = "=sum(" & rng.Address(False, False) & ")"
ActiveCell.Offset(2, 0).Formula = "=R[-2]C-R[-1]C"
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Formula = "=sum(" & rng.Address(False, False) & ")"
ActiveCell.Offset(2, 0).Formula = "=R[-2]C-R[-1]C"
ActiveCell.Offset(1, 0).Select
End If
End Sub
Visual Example: Here I would need the macro to continue extending range up untill C3 is reached and the calculated sum equals the initial selected cell C7
10221
Anyway hope its clear and maybe you guys can give me a hand on this one.
Thanks!
Nick
So this is my first post though I have been reading you for a while.
I wanted to share with you a code I created a while ago.
It works well but there is one thing pending to make it perfect. Maybe you can help me achieve this.
What this does is basically insert a SUM (below selected cell) and sets the range with the consecutive rows above the cell selected. Then (below sum function) it checks the difference between the selected cell and the new calculated SUM.
What I need help with is adding a loop function so if the sum() does not equal the selected cell then the range gets extended one cell up untill that value is reached or top of the page is reached.
The code I have today:
Sub AutoFootv2()
'
' AutoFootv2 Macro
' redo SUM, Compares against selected cell
' pending: extend sum range if selected cell and redone SUM are not equal
'
Dim rngStart As Range
Dim rng As Range
Set rngStart = ActiveCell
Set rng = Range(ActiveCell.Offset(-1, 0), ActiveCell.End(xlUp))
If ActiveCell.Offset(1, -1).Value = "" And ActiveCell.Offset(2, -1).Value = "" _
Then
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rngStart.Select
ActiveCell.Offset(1, 0).Formula = "=sum(" & rng.Address(False, False) & ")"
ActiveCell.Offset(2, 0).Formula = "=R[-2]C-R[-1]C"
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Formula = "=sum(" & rng.Address(False, False) & ")"
ActiveCell.Offset(2, 0).Formula = "=R[-2]C-R[-1]C"
ActiveCell.Offset(1, 0).Select
End If
End Sub
Visual Example: Here I would need the macro to continue extending range up untill C3 is reached and the calculated sum equals the initial selected cell C7
10221
Anyway hope its clear and maybe you guys can give me a hand on this one.
Thanks!
Nick