Updated:

Many thanks to Joris Claassen who provided feedback on how to better optimize this code. Please find the updated code below.

 

 

Hey guys,

As I continue my quest to become a master VBA programmer, I would like to share a piece of code with you that I recently constructed. This could was the result of Excel Solver not being able to generate a satisfactory solution to my optimization problem. Thus, I wanted to run a sensitivity analysis to see how various initial values would affect my target cell. This code allows the user to specify a target cell, a set of change cells, a range of lower bounds (inclusive) and a range of upper bounds (inclusive), as well as a precision level. The code then one-by-one tests the sensitivity of each of your change cells on your target cell and generates graphs demonstrating the output. I would appreciate any feedback on the code!

Thanks,
Adam

'Created by Adam McElhinney, 8/4/2011
'This code allows a user to specify a range of cells to adjust, a target cell as well as lower and upper bounds for their adjustments.
'Then the code generates a charts that determine how sensititive the target cell is to the input parameters. This can be useful for
'cases where Solver cannot generate a satisfactory solution.
Sub refit_model()
Call clear_sheet
Call calc_configs
Call ArrangeMyCharts




End Sub

'Clear Sheets
Sub clear_sheet()

Dim check As Worksheet






        Application.DisplayAlerts = False
        Sheets("output").Select
        Sheets("output").Cells.Clear
        

Dim wsSheet As Worksheet
On Error Resume Next
Set wsSheet = Sheets("graphs")
If Not wsSheet Is Nothing Then
wsSheet.Delete
Sheets.Add.Name = "graphs"

Else
Sheets.Add.Name = "graphs"
End If




    

End Sub


Sub calc_configs()
Application.ScreenUpdating = True

'Timer
'Dim Starttime As Double, EndTime As Double
'Startime = Timer


'Prompt user to select range of coefficients, lower bounds and upper bounds
Worksheets("calculation_configs").Activate
Dim variables As Range
Dim change As Range
Dim lower As Range
Dim upper As Range
Dim current As Range
Dim target As Range
Dim precision As Integer
Dim test_mode As Integer
Set variables = Application.InputBox("Select the row of variable names:", Default:=Range("a6:a19").Address, Type:=8)
Set current = Application.InputBox("Select the row of cells that are the current configs:", Default:=Range("b6:b19").Address, Type:=8)
Set change = Application.InputBox("Select the row of cells to change:", Default:=Range("c6:c19").Address, Type:=8)
Set lower = Application.InputBox("Select the row of cells that are lower bound:", Default:=Range("d6:d19").Address, Type:=8)
Set upper = Application.InputBox("Select the row of cells that are upper bound:", Default:=Range("e6:e19").Address, Type:=8)
Set target = Application.InputBox("Select the target cell", Default:=Range("k16").Address, Type:=8)
precision = Application.InputBox("Enter in the graphics precision:", Default:=10)

test_mode = (MsgBox("Do you want to run in test mode? Click 'Yes' for test mode or 'No' for regular mode. In test mode, cells will not recalculate.", vbYesNo))
    
        

    'Check to ensure that change, lower and upper are all same length
    Dim j, k, l As Integer
    j = change.Rows.Count
    k = lower.Rows.Count
    l = upper.Rows.Count
    If j <> k Or k <> l Then
        MsgBox ("The number of cells to change must equal the number of upper bounds and the number of lower bounds")
        Exit Sub
        
    End If

        
        
Application.ScreenUpdating = False


'Assign initial coefficients, lower bounds and upper bounds to an array

ReDim coeff(j) As Double
ReDim lowerb(j) As Double
ReDim upperb(j) As Double
Dim i As Integer
    i = 1
    For i = 1 To j
    coeff(i) = change.Cells(i, 1).value
    lowerb(i) = lower.Cells(i, 1).value
    upperb(i) = upper.Cells(i, 1).value
    'MsgBox (lower.Cells(i, 1).Value)
    Next i
    
        'QC Code
        'ReDim testdisplay(j) As Double
        'testdisplay = lowerb
        'MsgBox testdisplay(1) & "-" & testdisplay(2) & "-" & testdisplay(3) & "-" & testdisplay(4) & "-" & testdisplay(5) & "-" & testdisplay(6) & "-" & testdisplay(7) & "-" & testdisplay(8) & "-" & testdisplay(9) & "-" & _
        'testdisplay(10) & "-" & testdisplay(11) & "-" & testdisplay(12) & "-" & testdisplay(13) & "-" & testdisplay(14)
    

    'Determine distance between upper and lower bounds, as well as upper bound and initial values and lower bound and initial values
    ReDim distance(j) As Double
    ReDim UpperDistance(j) As Double
    ReDim LowerDistance(j) As Double
    i = 0
    For i = 1 To j
    distance(i) = upperb(i) - lowerb(i)
    UpperDistance(i) = upperb(i) - coeff(i)
    LowerDistance(i) = coeff(i) - lowerb(i)
    Next i
    
        'Determine the graphing precision change intervals
        ReDim interval(j) As Double
        For i = 1 To j
        interval(i) = distance(i) / precision
        'MsgBox (interval(i))
        Next i
        
        'QC Code
        
        'ReDim testdisplay2(j) As Double
        'testdisplay2 = distance
        'MsgBox testdisplay2(1) & "-" & testdisplay2(2) & "-" & testdisplay2(3) & "-" & testdisplay2(4) & "-" & testdisplay2(5) & "-" & testdisplay2(6) & "-" & testdisplay2(7) & "-" & testdisplay2(8) & "-" & testdisplay2(9) & "-" & _
        'testdisplay2(10) & "-" & testdisplay2(11) & "-" & testdisplay2(12) & "-" & testdisplay2(13) & "-" & testdisplay2(14)
        
    'Set all configs to current values
        change.value = current.value
        'Calc sum squares
        If test_mode = vbNo Then
            Application.CalculateFull
        End If
        'Record results
        
            'Create index variable
            Dim ObsCol As Range
            'ObsCol=Sheets("output").
           
            Dim ObsNum As Integer
            ObsNum = 1

        For i = 1 To j
        Sheets("output").Cells(1, i).value = variables.Cells(i, 1)
        Sheets("output").Cells(2, i).value = change.Cells(i, 1)
        Next i
        Sheets("output").Cells(1, j + 1).value = "Target"
        Sheets("output").Cells(1, j + 2).value = "ObsNum"
        Sheets("output").Cells(2, j + 1).value = target.Cells(1, 1).value
        Sheets("output").Cells(2, j + 2).value = ObsNum
        
        'New Counters
        Dim n As Integer
        Dim p As Integer
        n = 1
        p = 1
        
       
        



    'Iterate through each variable one by one in increments equal to the precision, calculating the value of the target
            i = 1
        'Loop for each variable
        For i = 1 To j
            'Set all configs to lower bounds
            change.value = lower.value
                
                
                'Loop for each increment
                For m = 1 To precision
                change.Cells(i, 1).value = m * interval(i) + lowerb(i)
                'MsgBox (m * interval(i) + lowerb(i))
                
                If test_mode = vbNo Then
                Application.CalculateFull
                End If
                    
                    
                    'Print output
                    n = 1
                    For n = 1 To j
                        'Write change values
                        Sheets("output").Cells(2 + i * precision - (precision - m), n).value = change.Cells(n, 1).value
                    Next n
                        'Write target value
                        Sheets("output").Cells(2 + i * precision - (precision - m), j + 1).value = target.value
                        'Obs Num
                        Sheets("output").Cells(2 + i * precision - (precision - m), j + 2).value = i * precision - (precision - m) + 1
                        
                Next m
        'Create graph of output
        Worksheets("output").Activate
        ActiveSheet.Shapes.AddChart.Select
        ActiveChart.SetSourceData Source:=Sheets("output").Range(Cells(i * precision - (precision - 1) + 2, j + 1), _
            Cells(i * precision + 2, j + 1))
                
                Debug.Print "Chart Target range:" & i * precision - (precision - 1) + 2 & "-" & j + 1
                
        ActiveChart.ChartType = xlLine
        ActiveChart.SeriesCollection(1).XValues = Sheets("output").Range(Cells(i * precision - (precision - 1) + 2, i), _
            Cells(i * precision + 2, i))
        ActiveChart.HasTitle = True
        ActiveChart.ChartTitle.Text = "Change in Target for a Change in Variable " & variables(i)
        ActiveChart.Location xlLocationAsObject, "graphs"
                Debug.Print "Chart Series range:" & ii * precision - (precision - 1) + 2 & "-" & i
        Next i



'Save workbook
Application.DisplayAlerts = False
'ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\amcelhinney\Desktop\" & test_file

EndTime = Timer
Debug.Print "Execution Time in seconds:", EndTime - Starttime

End Sub


Sub ArrangeMyCharts()
Worksheets("graphs").Activate

Dim iChart As Long
Dim nCharts As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Dim dWidth As Double
Dim nColumns As Long
dTop = 75 ' top of first row of charts
dLeft = 100 ' left of first column of charts
dHeight = 225 ' height of all charts
dWidth = 375 ' width of all charts
nColumns = 3 ' number of columns of charts

nCharts = ActiveSheet.ChartObjects.Count

Debug.Print nCharts


For iChart = 1 To nCharts
With ActiveSheet.ChartObjects(iChart)
.Height = dHeight
.Width = dWidth
.Top = dTop + Int((iChart - 1) / nColumns) * dHeight
.Left = dLeft + ((iChart - 1) Mod nColumns) * dWidth
End With



Next
End Sub


Sub ArrangeMyCharts_2()
Worksheets("Calculation_Configs").Activate

Dim iChart2 As Long
Dim nCharts2 As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Dim dWidth As Double
Dim nColumns As Long
dTop = 300 ' top of first row of charts
dLeft = 500 ' left of first column of charts
dHeight = 225 ' height of all charts
dWidth = 375 ' width of all charts
nColumns = 2 ' number of columns of charts

nCharts2 = ActiveSheet.ChartObjects.Count

Debug.Print nCharts2


For iChart2 = 1 To nCharts2
With ActiveSheet.ChartObjects(iChart2)
.Height = dHeight
.Width = dWidth
.Top = dTop + Int((iChart2 - 1) / nColumns) * dHeight
.Left = dLeft + ((iChart2 - 1) Mod nColumns) * dWidth
End With



Next
End Sub