Solved: is it possible to return a formula into a cell?

[sunilmulay]

Hi Guys
I don't know if you VBA pros can help with this one. I posted it on an Excel forum but haven't managed to get to the bottom of it yet.
Attached is a sample file:

On sheet 1TR, you'll see how columns K, L and other have formula referring to Column J (progress), and Sheet 1PL. I want the user to be able to enter a different value if they wish in Columns K and L from that returned by the formula, but if they subsequently change their mind, I want them to be able to delete their entry and the formula to return....

Someone suggested trying the following on my spreadsheet:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("K40").Value = "" Then Range("K40").Formula = "='1PL'!G40+(('1PL'!I40-'1PL'!G40)*J40)"
If Range("K46").Value = "" Then Range("K46").Formula = "='1PL'!G46+(('1PL'!I46-'1PL'!G46)*J46)"
End Sub

Trouble with that is i would have to enter a line for each cell, and there would be thousands of cells in this situation.

Is there a way to introduce a "wildcard" into the formula, so that for every row, the formula substitues row number 40 in the above formula with the row number for that cell....
I hope you know what I mean. Basically I want the formula that is currently in the cells to return if a user enters their own value into the cell and then deletes it.

Hope this makes sense...
Thanks

[mdmackillop]

Use the R1C1 reference eg
If Range("K40").Value = "" Then Range("K40").FormulaR1C1 = "='1PL'!RC[-4]+(('1PL'!RC[-2]-'1PL'!RC[-4])*RC[-1])"

[Bob Phillips]

You can run a loop as well



For i = 40 To 400 Step 6 'adjust to suit

With Cells(i, "K")

If .Value = "" Then

.Formula = "='1PL'!G" & i & "+(('1PL'!I" & i & "-'1PL'!G" & i & ")*J" & i & ")"
End If
End With
Next i

[mdmackillop]

XLD's solution will overwrite all user entered, so useful to "refresh" the sheet, but not for the situation you described.

[sunilmulay]

I'm going to try out XLD's soution... not sure what the "Step 6" does... Does it skip rows and select every 6th one to perform the macro on? If so, that won't work as it won't always be every 6th row..
However I could apply a rule, currently the rule would be that the formula should be applied to every row where Column A value is 1 and Column B value is 0. I'm going to try to put some code together based on the above - I'll post it on here if it doesn't work..
Thanks
S

[sunilmulay]

Right...I've tried the following...
Private Sub Worksheet_Change(ByVal Target As Range)
For i = 32 To 999
If Cells(i, 1).Value = 1 And Cells(i, 2).Value = "" Then

With Cells(i, "K")

If .Value = "" Then

.Formula = "='1PL'!G" & i & "+(('1PL'!I" & i & "-'1PL'!G" & i & ")*J" & i & ")"
End If
End With
End If
Next i
End Sub

This should stick the formula in to cells in column K as soon as the user deletes a value in this column, right? Unfortunately, it's not doing anything....

thanks
sunil

[rbrhodes]

Hi sunil,

This sub will replace the formula if it is deleted. The user will have to type over the existing one.


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim tRow As Long

'Added on edit
on error goto endo

'Check if change is in range <==Change to suit
If Not Intersect(Target, Range("K21:K999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!G" & tRow & "+(('1PL'!I" & tRow & "-'1PL'!G" & tRow & ")*J" & tRow & " )"
End If
ElseIf Not Intersect(Target, Range("L21:L999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!H" & tRow & "-('1PL'!H" & tRow & "*J" & tRow & ")"
End If
End If

'Exit on error
endo:
End Sub

[rbrhodes]

Or you could just ask the user...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim tRow As Long
Dim UserFormula As Long
On Error GoTo endo

'Check if change is in range <==Change to suit
If Not Intersect(Target, Range("K21:K999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
UserFormula = MsgBox("Enter custom formula?", vbYesNo)
If UserFormula = 7 Then
'No. Restore formula
tRow = Target.row
Target = "='1PL'!G" & tRow & "+(('1PL'!I" & tRow & "-'1PL'!G" & tRow & ")*J" & tRow & " )"
End If
End If
ElseIf Not Intersect(Target, Range("L21:L999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
UserFormula = MsgBox("Enter custom formula?", vbYesNo)
If UserFormula = 7 Then
'No. Restore formula
tRow = Target.row
Target = "='1PL'!H" & tRow & "-('1PL'!H" & tRow & "*J" & tRow & ")"
End If
End If
End If
'Exit on error
endo:
End Sub

[sunilmulay]

hi dr
you guys on this forum are real geniuses! I had no idea this would really be possible, but your code is exactly what I was trying to achieve. It appears anything is possible with VBA!!

I'm going to push your expertise on this situation a bit further (if I may), but before that, I need to ask you something simple. What's the best way to extend the above code to return more target formulas into other columns. I want to do a similar thing for columns O, R, U, X and AA. Do I just create new subs for them or add ElseIf Not clauses in the above code? I actually tried adding Else If not clauses, but that didn't work, so tried the following:
Private Sub ColOColR_Change(ByVal Target As Range)

Dim tRow As Long

'Added on edit
On Error GoTo endo

'Check if change is in range <==Change to suit
If Not Intersect(Target, Range("O21:O999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!K" & tRow & "-('1PL'!K" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("R21:R999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!N" & tRow & "-('1PL'!N" & tRow & "*J" & tRow & ")"
End If
End If

'Exit on error
endo:
End Sub
Private Sub ColUColX_Change(ByVal Target As Range)

Dim tRow As Long

'Added on edit
On Error GoTo endo

'Check if change is in range <==Change to suit
If Not Intersect(Target, Range("U21:U999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!Q" & tRow & "-('1PL'!Q" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("X21:X999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!T" & tRow & "-('1PL'!T" & tRow & "*J" & tRow & ")"
End If
End If

'Exit on error
endo:
End Sub

but that doesn't work either.... How do I get those target formulas for columns O, R, U, X into the code as well???

And now for the more challenging bit(!):
Column J contains progress. Let's say the value in a cell in that column is currently 20%. If the user changes the value to, say 50%, I want the corresponding current values in columns L, O, R, U, X and AA to all reduce by 30% (50%-20%). Any ideas how to achieve this?
(I know I'm asking for a lot here!!)
thanks
Sunil

p.s. I'm probably making the most basic mistakes... forgive me as I am a complete beginner...

[rbrhodes]

Hi Sunil,

You can only have one change event per sheet so I combined all of your code into one, is this what you wanted? There are other ways to write this but lets see if this does what you want...



Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim tRow As Long
Dim UserFormula As Long
On Error GoTo endo

'Check if change is in range <==Change to suit
If Not Intersect(Target, Range("K21:K999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!G" & tRow & "+(('1PL'!I" & tRow & "-'1PL'!G" & tRow & ")*J" & tRow & " )"
End If
ElseIf Not Intersect(Target, Range("L21:L999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!H" & tRow & "-('1PL'!H" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("O21:O999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!K" & tRow & "-('1PL'!K" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("R21:R999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!N" & tRow & "-('1PL'!N" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("U21:U999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!Q" & tRow & "-('1PL'!Q" & tRow & "*J" & tRow & ")"
End If
ElseIf Not Intersect(Target, Range("X21:X999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!T" & tRow & "-('1PL'!T" & tRow & "*J" & tRow & ")"
End If
End If

'Exit on error
endo:
End Sub


As for your second request it appears to me that your sample sheet does exactly that.?? What am I missing?

[sunilmulay]

Hi there
I tried combining all the code into one like you have done myself, but it didn't work. I'll try your version a later today (don't have the file) and let you know what happens.

Regarding my second question, you're right the formula currently does just that. However, I want users to be able to overwrite the formula and enters their own value. In this instance, next time they come around to update the progress on each task, I want the value they entered manually to be factored down accordingly.

Do you understand what I'm trying to achieve now?

THanks a bunch
S

[sunilmulay]

hi DR

Right, I tried you're code (with minor modifications to suit the formula I've developed), and it works brilliantly.

now, I don't think I've explained myself well enough with regards to my second problem.

Right, this is how I see it working:
Day 1: user goes into tracking sheet and updates progress to 10% (say). Other columns update themselves accordingly based on the formulas I have in there. All good

Day 2. User goes into tracking sheet, updates progress to say 20%, then also manually overtypes the values for Duration, and manhours, because they are not happy with the values returned by the formula. So far so good.

Day 3. User goes into tracking sheet and updates progress to say, 30%. this time I want the values in the other columns (which, remember are now user entered values and not calculated by formulas) to reduce by 10% (30%-20%). (this is the missing bit I need to try and sort out)

Day 4. user updates progress to 40%. User then deletes corresponding values for duration, etc (for whatever reason). I need the original formula to jump back in (this is now sorted with your brilliant piece of code!)

I hope you get the picture now...
thanks
Sunil

[rbrhodes]

Hi sunil,

Try this combo of subs. The only thing is it lowers the manually entered cell by the percentage difference entered and I'm not sure that's what you wanted. In other words

- the Progress cell is at 20%

- a number is entered manually

- the progress cell is changed to 30%

- the entered number will change by 10% _of its original value_

Is that right?


Option Explicit
'
Public OldL As Long
Public OldO As Double
Public OldR As Double
Public OldU As Double
Public OldX As Double
Public OldAA As Double
Public OldPerCent As Double
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("J21:J999")) Is Nothing Then '<==change range to suit
'Get old percent value
If IsNumeric(Target.Value) Then
OldPerCent = Target.Value
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)

Dim tRow As Long
Dim UserFormula As Long
Dim NewPerCent As Double

On Error GoTo endo

Application.EnableEvents = False

'Change in Per Cent
If Not Intersect(Target, Range("J21:J999")) Is Nothing Then
'Get change in value
NewPerCent = (Target.Value - OldPerCent)
'Get row
tRow = Target.row
'Check if formulas or not
If Not Range("L" & tRow).HasFormula Then
Range("L" & tRow) = Range("L" & tRow) - (OldL * NewPerCent)
End If
If Not Range("O" & tRow).HasFormula Then
Range("O" & tRow) = Range("O" & tRow) - (OldO * NewPerCent)
End If
If Not Range("R" & tRow).HasFormula Then
Range("R" & tRow) = Range("R" & tRow) - (OldR * NewPerCent)
End If
If Not Range("U" & tRow).HasFormula Then
Range("U" & tRow) = Range("U" & tRow) - (OldU * NewPerCent)
End If
If Not Range("X" & tRow).HasFormula Then
Range("X" & tRow) = Range("W" & tRow) - (OldX * NewPerCent)
End If
If Not Range("AA" & tRow).HasFormula Then
Range("AA" & tRow) = Range("AA" & tRow) - (OldAA * NewPerCent)
End If

'Check if change is in range <==Change to suit
ElseIf Not Intersect(Target, Range("K21:K999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!G" & tRow & "+(('1PL'!I" & tRow & "-'1PL'!G" & tRow & ")*J" & tRow & " )"
End If
ElseIf Not Intersect(Target, Range("L21:L999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!H" & tRow & "-('1PL'!H" & tRow & "*J" & tRow & ")"
Else
OldL = Target.Value
End If
ElseIf Not Intersect(Target, Range("O21:O999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!K" & tRow & "-('1PL'!K" & tRow & "*J" & tRow & ")"
Else
OldO = Target.Value
End If
ElseIf Not Intersect(Target, Range("R21:R999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!N" & tRow & "-('1PL'!N" & tRow & "*J" & tRow & ")"
Else
OldR = Target.Value
End If
ElseIf Not Intersect(Target, Range("U21:U999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!Q" & tRow & "-('1PL'!Q" & tRow & "*J" & tRow & ")"
Else
OldU = Target.Value
End If
ElseIf Not Intersect(Target, Range("X21:X999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!T" & tRow & "-('1PL'!T" & tRow & "*J" & tRow & ")"
Else
OldX = Target.Value
End If
ElseIf Not Intersect(Target, Range("AA21:AA999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!W" & tRow & "-('1PL'!W" & tRow & "*J" & tRow & ")"
Else
OldAA = Target.Value
End If
End If

'Exit on error
endo:
Application.EnableEvents = True

End Sub

[sunilmulay]

Wow - that's quite something. There's no way I could have written that by myself. Assuming the code above works (I'll try tonight), yes, it is exactly what I was looking for.

Thinking it through further now, though, I realise that really I need to change the calculation for the third item. I will try and do this myself. Basically what I want is this;
If orginal % = 10% (or 0.1)
and user entered % = 20% (or 0.2)
and user entered value for say duration = 100hrs,
I need the duration value to be calculate as = 100 - [(100*(1+0.1))*(0.2-0.1)]

I'll try this myself later in the evening....hopefully it will be easy enough...and I'll let you know how I go..

Thanks!
S

[mdmackillop]

If Not Range("L" & tRow).HasFormula Then
Range("L" & tRow) = Range("L" & tRow) - (OldL * NewPerCent)
End If
Maybe I'm missing someting, but where does OldL etc. get a value?

[sunilmulay]

You know, MDMacKillop, I was wondering that too, and I think it takes the definition from further down the code. Anyway it works just as I had set out my intentions.

DR - I've played around with it to get exactly what I wanted. Below is the final result fyi. I really don't know how it's working exactly (I'll need to study it + I am a beginner), but it works like magic!! I'm lucky to be surrounded by geniuses!! :-)

Option Explicit
'
Public OldL As Long
Public OldO As Double
Public OldR As Double
Public OldU As Double
Public OldX As Double
Public OldAA As Double
Public OldPerCent As Double
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("J21:J999")) Is Nothing Then '<==change range to suit
'Get old percent value
If IsNumeric(Target.Value) Then
OldPerCent = Target.Value
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)

Dim tRow As Long
Dim UserFormula As Long
Dim NewPerCent As Double

On Error GoTo endo

Application.EnableEvents = False

'Change in Per Cent
If Not Intersect(Target, Range("J21:J999")) Is Nothing Then
'Get change in value
NewPerCent = (Target.Value - OldPerCent)
'Get row
tRow = Target.row
'Check if formulas or not
If Not Range("L" & tRow).HasFormula Then
Range("L" & tRow) = Range("L" & tRow) - (NewPerCent * (Range("L" & tRow) / (1 - OldPerCent)))
End If
If Not Range("O" & tRow).HasFormula Then
Range("O" & tRow) = Range("O" & tRow) - (NewPerCent * (Range("O" & tRow) / (1 - OldPerCent)))
End If
If Not Range("R" & tRow).HasFormula Then
Range("R" & tRow) = Range("R" & tRow) - (NewPerCent * (Range("R" & tRow) / (1 - OldPerCent)))
End If
If Not Range("U" & tRow).HasFormula Then
Range("U" & tRow) = Range("U" & tRow) - (NewPerCent * (Range("U" & tRow) / (1 - OldPerCent)))
End If
If Not Range("X" & tRow).HasFormula Then
Range("X" & tRow) = Range("W" & tRow) - (NewPerCent * (Range("X" & tRow) / (1 - OldPerCent)))
End If
If Not Range("AA" & tRow).HasFormula Then
Range("AA" & tRow) = Range("AA" & tRow) - (NewPerCent * (Range("AA" & tRow) / (1 - OldPerCent)))
End If

'Check if change is in range <==Change to suit
ElseIf Not Intersect(Target, Range("K21:K999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "=IF(J" & tRow & "=0,'1PL'!G" & tRow & ",IF('1TR'!J" & tRow & "=1,'1PL'!I" & tRow & ",TODAY()))"
End If
ElseIf Not Intersect(Target, Range("L21:L999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!H" & tRow & "-('1PL'!H" & tRow & "*J" & tRow & ")"
Else
OldL = Target.Value
End If
ElseIf Not Intersect(Target, Range("O21:O999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!K" & tRow & "-('1PL'!K" & tRow & "*J" & tRow & ")"
Else
OldO = Target.Value
End If
ElseIf Not Intersect(Target, Range("R21:R999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!N" & tRow & "-('1PL'!N" & tRow & "*J" & tRow & ")"
Else
OldR = Target.Value
End If
ElseIf Not Intersect(Target, Range("U21:U999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!Q" & tRow & "-('1PL'!Q" & tRow & "*J" & tRow & ")"
Else
OldU = Target.Value
End If
ElseIf Not Intersect(Target, Range("X21:X999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!T" & tRow & "-('1PL'!T" & tRow & "*J" & tRow & ")"
Else
OldX = Target.Value
End If
ElseIf Not Intersect(Target, Range("AA21:AA999")) Is Nothing Then
'Check if blank (deleted)
If Target = "" Then
'Yes. Restore formula
tRow = Target.row
Target = "='1PL'!W" & tRow & "-('1PL'!W" & tRow & "*J" & tRow & ")"
Else
OldAA = Target.Value
End If
End If

'Exit on error
endo:
Application.EnableEvents = True
End Sub



Thank you very much indeed.

Sunil

[rbrhodes]

Hi guys,

I guess I should have commented the code better! I just kinda made this up to se if I was going in the right direction with it. If so I'll re-code it with comments... <g>

dr

[sunilmulay]

HI DR
I have just posted another thread, where I have tried to solve my problem by cutting and pasting bits of your code above, but it doesn't quite resolve my challenge.
I was wondering if you could help.....
Thanks
S