VBA Express : Excel - Multiple Goal Seek code

Excel

Multiple Goal Seek code

Ease of Use

Easy

Version tested with

2000, 2003

Submitted by:

brettdj

Description:

This macro runs Excel's goal seek over a range of cells

Discussion:

If you have ever run goal seek over 20 cells in a row, cell by cell, to perhaps balance inventory levels or to fudge the profit level, then this code is for you.

Code:

instructions for use

			Option Explicit 
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.Columns.Count 
        TargetVal.Cells(i).GoalSeek Goal:=DesiredVal.Cells(i).Value, ChangingCell:=ChangeVal.Cells(i) 
    Next i 
End Sub

How to use:

Copy the code above.
Open your workbook.
Hit Alt+F11 to open the Visual Basic Editor (VBE).
From the menu, choose Insert-Module.
Paste the code into the code window at right.
Close the VBE, and save the file if desired.

Test the code:

Run the macro Multi_Goal_Seek by going to Tools-Macro-Macros and double-click Multi_Goal_Seek

Sample File:

MultipleGoalSeek(KB19).zip 20.34KB

Approved by mdmackillop

This entry has been viewed 366 times.