Goal Seek

[mynam]

HI,

Is there a way to omit minus numbers in goal seek?

Thanks..

 

[Oaktree]

No, but Goal Seek's output can vary with different initial values.

Consider the simple example of B2 = A2^2

If A2's initial value is 0 and you goal seek B2 to be 4, Goal seek will find the solution A2 = 2 (give or take rounding precision).

If A2's initial value is -100 and you goal seek B2 to be 4, Goal seek will find the solution A2 = -2 (also give or take rounding precision).

Otherwise, if your model is set up in a way that would allow you to use the Solver add-in, you could go that route where you could put constraints (such as non-negative) into the solution's requirements.

 

[mynam]

Hi,

Thanks a lot. I already have a macro for multiple goal seek. Is there a way to modify it so that I can omit negative values?

Thanks.

 

[shg]

I think you will need to switch to Solver as Oaktree suggested, to enable the use of constraints.

Post the code you have now for multiple goal seek, and I or someone else can help you modify it.

 

[mynam]

This is the macro.

Sub Multi_Goal_Seek()
Dim TargetVal As Range, DesiredVal As Range, ChangeVal As Range, CVcheck As Range
Dim CheckLen As Long, i As Long

restart:
With Application
Set TargetVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select your range which contains the ""Set Cell"" range", Default:=Range("C11:E11").Address, Type:=8)
'no default option
'prompt:="Select your range which contains the ""Set Cell"" range",, Type:=8)
Set DesiredVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select the range which the ""Set Cells"" will be changed to", Default:=Range("C12:E12").Address, Type:=8)
'no default option
'prompt:="Select the range which the ""Set Cells"" will be changed to",, Type:=8)
Set ChangeVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select the range of cells that will be changed", Default:=Range("G8:G10").Address, Type:=8)
'no default option
'prompt:="Select the range of cells that will be changed",, Type:=8)
End With

'Ensure that the changing cell range contains only values, no formulas allowed
Set CVcheck = Intersect(ChangeVal, Union(Sheets(ChangeVal.Parent.Name).Cells.SpecialCells(xlBlanks), Sheets(ChangeVal.Parent.Name).Cells.SpecialCells(xlConstants)))
If CVcheck Is Nothing Then
MsgBox "Changing value range contains no blank cells or values" & vbNewLine & _
"Goal seek only works if the cells to be changed are values, please ensure that this is the case", vbCritical
Application.GoTo reference:=DesiredVal
Exit Sub
Else

If CVcheck.Cells.Count <> DesiredVal.Cells.Count Then
MsgBox "Changing value range contains formulas" & vbNewLine & _
"Goal seek only works if the cells to be changed are values, please ensure that this is the case", vbCritical
Application.GoTo reference:=DesiredVal
Exit Sub
End If
End If

'Ensure that the amount of cells is consistent
If TargetVal.Cells.Count <> DesiredVal.Cells.Count Or TargetVal.Cells.Count <> ChangeVal.Cells.Count Then
CheckLen = MsgBox("Ranges were different lengths, please press yes to re-enter", vbYesNo + vbCritical)
If CheckLen = vbYes Then
'If ranges are different sizes and user wants to redo then restart code
GoTo restart
Else
Exit Sub
End If
End If

' Loop through the goalseek method
For i = 1 To TargetVal.Rows.Count
TargetVal.Cells(i).GoalSeek Goal:=DesiredVal.Cells(i).Value, ChangingCell:=ChangeVal.Cells(i)
Next i
End Sub

Thanks...

 

[shg]

Untested, other than that it compiles.

Sub MultiSolve()
    Dim rTgt        As Range
    Dim rVal        As Range
    Dim rChg        As Range
    Dim rBad        As Range
    Dim i           As Long
 
    Do
        Set rTgt = Application.InputBox(Title:="Select a range in a single row or column", _
                                        Prompt:="Select your range which contains the ""Set Cell"" range", _
                                        Default:="C11:E11", _
                                        Type:=8)
        Set rTgt = Intersect(rTgt, rTgt.Worksheet.UsedRange)
 
        Set rVal = Application.InputBox(Title:="Select a range in a single row or column", _
                                        Prompt:="Select the range which the ""Set Cells"" will be changed to", _
                                        Default:="C12:E12", _
                                        Type:=8)
        Set rVal = Intersect(rVal, rVal.Worksheet.UsedRange)
 
        Set rChg = Application.InputBox(Title:="Select a range in a single row or column", _
                                        Prompt:="Select the range of cells that will be changed", _
                                        Default:="G8:G10", _
                                        Type:=8)
        Set rChg = Intersect(rChg, rChg.Worksheet.UsedRange)
 
        If rTgt.Cells.Count = rVal.Cells.Count And _
           rTgt.Cells.Count = rChg.Cells.Count Then Exit Do
 
        If MsgBox(Prompt:="Ranges were different lengths, please press yes to re-enter, no to quit", _
                  Buttons:=vbYesNo + vbCritical) = vbNo Then Exit Sub
    Loop
 
    On Error Resume Next
    Set rBad = rChg.SpecialCells(xlCellTypeFormulas)
    If Not rBad Is Nothing Then
        rBad.Select
        MsgBox "No formulas allowed in changing cells!"
        Exit Sub
    End If
 
    Set rBad = rBad.SpecialCells(xlCellTypeBlanks)
    If Not rBad Is Nothing Then
        rBad.Select
        MsgBox "No blanks allowed in changing cells!"
        Exit Sub
    End If
 
    On Error GoTo 0
 
    For i = 1 To rTgt.Rows.Count
        SolverReset
        SolverOk setcell:=rTgt(i).Address, _
                 MaxMinVal:=3, _
                 ValueOf:=rVal(i).Value, _
                 ByChange:=rChg(i).Address
        SolverAdd CellRef:=rChg(i).Address, _
                  Relation:=3, _
                  FormulaText:=0
        SolverSolve UserFinish:=True
    Next i
End Sub

Code tags make code a little more legible, don't you think?

 

[mynam]

Thanks for the code.
I replace the previous code with this one. But there is some error coming up in the line which has "SolverReset".
Sorry, I'm not very good in vba coding.

 

[shg]

Ah -- you have to set a reference to Solver:

In the VBE, Tools > References, paste this in the File name box
C:\Program Files\Microsoft Office\OFFICExx\Library\SOLVER<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
… after replacing xx with your version of Excel (e.g., 11 for Excel 2003, 12 for Excel 2007).
Change the file type dropdown to *.xls, *.xla, and pick SOLVER.XLA<o></o>

You may also need to run Solver once from the user interface, and for that you need to enable the Solver add-in from the UI. (Excel Options > Add-Ins, press the Go button, tick Solver)

 

[mynam]

Thanks. Now its working perfectly.
Cheers...

 

[shg]

You're welcome, cheers.

EDIT: This line

 Set rBad = rBad.SpecialCells(xlCellTypeBlanks)

should be

 Set rBad = rChg.SpecialCells(xlCellTypeBlanks)