Category Archives: VBA

VBA Code to Standardize a User Specified Range by Column

25 Thursday Aug 2011

Posted by in Statistics, VBA

≈ Leave a comment

Hey guys,

I wanted to share some new code with you. The code below allows a user to specify a range of data and then the code will output the standardized values (mean=0 and standard deviation 1) for each of the columns. This can be a big time saver over Excel’s standardize function, which requires the user to input the mean and standard deviation and only standardizes one cell at a time. Also, this allows the user to specify specifically how they want the standard deviation calculated.

I hope that you guys enjoy the code. I welcome any feedback!

Thanks,
Adam

 

 

Sub standardize_range()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This code allows a user to select a group of data organized by columns and it will provide a standardized
'output with mean 0, variance 1
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim variables As Range
Dim change As Range
Set variables = Application.InputBox("Select the row of variable names:", Default:=Range("a1:c1").Address, Type:=8)
Set change = Application.InputBox("Select the row of cells containing the data to standardize:", Default:=Range("a2:c14").Address, Type:=8)
Dim Total, Total_sq, Average, Variance As Double




numRow = change.Rows.Count
numCol = change.Columns.Count
'Debug.Print "numrow=" & numrow & " numcol=" & numCol




'1. Calculate Average and Std for all Columns
'Note: This calculation for Variance and StdDev differs from Excel's slightly



For j = 1 To numCol
    
    ReDim col(numRow) As Double
    Total = 0
    Total_sq = 0
    
    For i = 1 To numRow
        col(i) = change.Cells(i, j)
        'Debug.Print col(i)
        Total = Total + col(i)
        Total_sq = Total_sq + col(i) ^ 2
    Next i
    
    Average = Total / numRow
    Variance = (Total_sq / numRow) - (Average) ^ 2
    Std = Variance ^ (1 / 2)
        'Debug.Print "Total="; Total & " Average="; Average & " Total_sq=" & Total_sq & " Variance=" & Variance _
        '& " Std=" & Std
    
    'Store values
    change.Cells(numRow + 1, j).Value = Average
    change.Cells(numRow + 2, j).Value = Variance
    change.Cells(numRow + 3, j).Value = Std
    
Next j

'2. Create Sheet to store standardized values
Application.DisplayAlerts = False
Sheets("Standardized_Values").Delete
Sheets.Add.Name = "Standardized_Values"

    'Write variable names
    For k = 1 To numCol
    Sheets("Standardized_Values").Cells(1, k).Value = variables.Cells(1, k) & "_std"
    Next k

'3. Compute standardized values
For n = 1 To numCol

  
  
    For m = 1 To numRow

        Sheets("Standardized_Values").Cells(m + 1, n).Value = (change.Cells(m, n).Value - change.Cells(numRow + 1, n).Value) / _
        change.Cells(numRow + 3, n).Value
    Next m
Next n

End Sub

 

 

Excel VBA Code to Generate Sensitivity Graphs Based on User Specified Ranges

05 Friday Aug 2011

Posted by in Optimization, VBA

≈ 1 Comment

Tags

, , ,

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