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