100 Excel VBA Simulations
100 Excel VBA Simulations
com
www.Ebook777.com
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Dr. Gerard M. Verschuuren
www.Ebook777.com
I. TABLE OF CONTENTS
I. GAMBLING
Chapter 1: The Die Is Cast
Chapter 2: Casting Six Dice
Chapter 3: Roulette Machine
Chapter 4: An X-O Game
Chapter 5: A Slot Machine
Chapter 6: Gamblers’ Ruin
Chapter 7: Lottery Numbers
Chapter 8: Win or Lose?
Chapter 9: A Letter Game
Chapter 10: A Three-Way Circuit
Chapter 11: Flock Behavior
II. STATISTICS
Chapter 12: Samples
Chapter 13: A Normal Distribution
Chapter 14: Distribution Simulations
Chapter 15: Discrete Distributions
Chapter 16: Peaks
Chapter 17: Confidence Margins
Chapter 18: Sample Size and Confidence Interval
Chapter 19: Random Repeats
Chapter 20: Flipping a Fair Coin?
Chapter 21: Simulation of Sick Cases
Chapter 22: Unbiased Sampling
Chapter 23: Transforming a LogNormal Distribution
Chapter 24: Outlier Detection
Chapter 25: Bootstrapping
Chapter 26: Bean Machine Simulation
Chapter 27: Correlated Distributions
Chapter 28: Sorted Random Sampling
Chapter 29: Frequencies
IV. GENETICS
Chapter 40: Shuffling Chromosomes
Chapter 41: Sex Determination
Chapter 42: Mendelian Laws
Chapter 43: The Hardy-Weinberg Law
Chapter 44: Genetic Drift
Chapter 45: Two Selective Forces
Chapter 46: Differential Fitness
Chapter 47: Molecular Clock
Chapter 48: DNA Sequencing
V. SCIENCE
Chapter 49: Matrix Elimination
Chapter 50: Integration with Simulation
Chapter 51: Two Monte Carlo Integrations
Chapter 52: Monte Carlo Approach of Pi
Chapter 53: A Population Pyramid
Chapter 54: Predator-Prey Cycle
Chapter 55: Taking Medication
Chapter 56: The Course of an Epidemic
Chapter 57: Boltzmann Equation for Sigmoidal Curves
Chapter 58: Interpolation
Chapter 59: A Rigid Pendulum
Chapter 60: A Piston Sinusoid
Chapter 61: The Brusselator Model
Chapter 62: A Hawk-Dove Game
VI. BUSINESS
Chapter 63: Prognosis of Sales
Chapter 64: Cycle Percentiles
Chapter 65: Cost Estimates
Chapter 66: A Filtering Table
Chapter 67: Profit Changes
Chapter 68: Risk Analysis
Chapter 69: Scenarios
Chapter 70: Market Growth
Chapter 71: A Traffic Situation
Chapter 72: Quality Control
Chapter 73: Waiting Time Simulation
Chapter 74: Project Delays
VII. FINANCE
Chapter 75: Buy or Sell Stock
Chapter 76: Moving Averages
Chapter 77: Automatic Totals and Subtotals
Chapter 78: Fluctuations of APR
Chapter 79: Net Present Value
Chapter 80: Loan with Balance and Principal
Chapter 81: S&P500 Performance
Chapter 82: Stock Market
Chapter 83: Stock Volatility
Chapter 84: Return on Investment
Chapter 85: Value at Risk
Chapter 86: Asian Options
VIII. MISCELLANEA
Chapter 87: Cracking a Password
Chapter 88: Encrypting Text
Chapter 89: Encrypting a Spreadsheet
Chapter 90: Numbering Records
Chapter 91: Sizing Bins for Frequencies
Chapter 92: Creating Calendars
Chapter 93: Populating a Jagged Array
Chapter 94: Filtering a Database
Chapter 95: Formatting Phone Numbers
Chapter 96: Creating Gradients
Chapter 97: Aligning Multiple Charts
Chapter 98: Temperature Fluctuations
Chapter 99: Working with Fiscal Years
Chapter 100: Time Calculations
IX. APPENDIX
Data Tables
If Statements
Value Type Variables
Ranges vs. Cells
FormulaR1C1
Arrays
Error Handling
X. INDEX
Free ebooks ==> www.Ebook777.com
II. INSTRUCTIONS
All simulations in this book are supported by files that you can
download from the following website:
http://www.genesispc.com/download/100VBAsimulations.zip.
I assume that you are already familiar with many Excel features,
including graphs or charts. In this book, I will only explain in more detail
those features that are very helpful when you do what-if-analysis with
simulations. For more basic features of Excel, I would refer you to some
learning tools that you can find on www.mrexcel.com/microsoft-office-
visual-learning.html.
If you want to create simulations exclusively with Excel functions and
formulas, without using VBA, I recommend another book:
http://genesispc.com/tocsimulations100.htm.
This book is not about the basics of Visual Basic (VBA) either. It only
uses VBA to make simulations faster, better, and more user-friendly. If you
want to learn VBA from the bottom up, I would recommend my interactive
CD-ROM: http://genesispc.com/tocvba2013CD.htm. Yet, here are a few
basic rules for using VBA:
• To start a new command line in VBA, use ENTER.
• Never use ENTER inside a command line. (In this book
lines may wrap to the next line, but in VBA that is not
allowed.)
• A colon (:) can separate amd combine several commands
on the same line
• Use an apostrophe (‘) for a comment after, or at the end
of, a command line.
• To create shortcuts in Excel for a macro (or Sub in VBA),
you need the Developers tab (if that tab is missing, go to File
Options | Macros | Options | Shift + a character.
• Files with macros open with the message “Enable
Content.” If you find that annoying place such files in a so-
called Trusted Location: Files | Options | Trust Center | Trust
Center Setting | Trusted Locations.
www.Ebook777.com
• To open VBA, you can use this shortcut: ALT F11.
• On the VBA screen, choose: Insert | Module.
• I always use Option Explicit in VBA: Tools | Options |
Require Variable Declaration.
• This means you always have to declare variables with a
Dim statement.
• There are value type variables such as integer, double,
string (see Appendix) and object type variables (Range,
Sheet). The latter require the Set keyword.
• Type a dot (.) after an object such as Range or Chart in
order to get access to its properties and methods.
• It is wise to use consistent indentation to make your code
more readable and checkable.
• A With statement allows us to refer to it later with just a
simple dot (.), followed by a property or method.
• Formulas are always strings in VBA, so they should be
inside double quotes (“...”). If there are double quotes inside
those double quotes, they should be “”...””.
• To split a long string into several lines, you use
endquotes-space-ampersand-space-underscore-enter-
openquotes.
• To interrupt running code, use Ctrl + Break.
• If your VBA code ever runs into trouble (and it will!),
make sure you stop the Debugger before you can run the code
again. You do so by clicking the Reset button:
•
I. GAMBLING
Chapter 1: The Die Is Cast
What the simulation does
Sub Dice()
Dim i As Integer
Again: 'this is called a label that we use at the end
to go back to
i = Int(Rnd * 6) + 1
Range("B3") = IIf(i > 1, "O", "")
Range("D3") = IIf(i > 3, "O", "")
Range("B5") = IIf(i = 6, "O", "")
Range("C5") = IIf(i = 1 Or i = 3 Or i = 5, "O", "")
Range("D5") = IIf(i = 6, "O", "")
Range("B7") = IIf(i > 3, "O", "")
Range("D7") = IIf(i > 1, "O", "")
If i = 6 Then Exit Sub
If MsgBox("Number " & i & vbCr & "Again?",
vbOKCancel) = vbOK Then GoTo Again
End Sub
Chapter 2: Casting Six Dice
What the simulation does
This time we have six different dice. Each die “listens” to a random
number in VBA. The settings for each die are similar to what we did in
simulation 1.
There is not much new on this sheet. The main difference is that we
need 6 different cells with a RAND function in order to control the six die
displays. This is done with a For-loop in VBA, running from 0 to 5 (or 1 to
6).
When there are at least 3 dice in a row with six eyes, all dice get
marked at the same time.
What you need to know
A variable of the Variant type can hold an array of items. We fill the
array here by using the Array function in VBA. This array starts at 0 (that’s
why the For-loop runs from 0 to 5 instead of from 1 to 6). Notice that cell
rows and columns always start at 1 (not 0).
VBA can use almost all Excel functions by calling them with
WorksheetFunction. In this case we use Excel’s COUNTBLANK function.
The use of Range and Cells in VBA can be very powerful, but can
also be rather confusing at first sight (see Appendix). Range(“A1”) is
equivalent to Cells(1,1), but the latter one is more flexible in loops because
we can use a loop variable for the row and/or the column position.
Sometimes, they are combined: Range(Cells(1,1),Cells(10,2)) would refer
to A1:B10.
Another important tool in VBA is Offset, with which you can specify
the row offset and the column offset. For instance, Range(“A1”).Offset(2,2)
would evaluate to cell C3.
Don’t confuse End Sub with Exit Sub. Each Sub must close with End
Sub. But if you want to prematurely end the Sub routine, you must use Exit
Sub.
What you need to do
Sub Dice()
Dim vArr As Variant, i As Integer, r As Integer, n
As Integer, iSix As Integer, oRange As Range
Sheet1.Cells.Interior.ColorIndex = 0
vArr = Array("B3", "F3", "J3", "N3", "R3",
"V3")
Again:
Sheet1.Cells = ""
iSix = 0
For r = 0 To 5
Set oRange = Range(Range(vArr(r)),
Range(Range(vArr(r)).Offset(4, 2).Address))
With oRange
i = Int(Rnd * 6) + 1
.Cells(1, 1) = IIf(i > 1, "O", "")
.Cells(1, 3) = IIf(i > 3, "O", "")
.Cells(3, 1) = IIf(i = 6, "O", "")
.Cells(3, 2) = IIf(i = 1 Or i = 3 Or i = 5, "O",
"")
.Cells(3, 3) = IIf(i = 6, "O", "")
.Cells(5, 1) = IIf(i > 3, "O", "")
.Cells(5, 3) = IIf(i > 1, "O", "")
If WorksheetFunction.CountBlank(.Cells)
= 9 Then iSix = iSix + 1
End With
Next r
n=n+1
If iSix >= 3 Then
Cells.Interior.Color = vbYellow
MsgBox "3x6 or more! After " & n & " runs."
Exit Sub
End If
If MsgBox(n & " runs. Again?", vbOKCancel) =
vbOK Then GoTo Again
End Sub
Chapter 3: Roulette Machine
What the simulation does
Most people believe that if they keep consistently betting “odd,” the
ball will most certainly land on an odd number sometime soon. This is
called “the law of averages” which says, the longer you wait for a certain
random event, the more likely it becomes.
Do not believe it! Try it out in this “real life” simulation and find out
how the casino makes money on people who think that way. You may
initially gain but eventually lose.
The code clears previous results in the columns A:C when you start
the code. Column A simulates a roulette with 1,000 random numbers
between 1 and 36. In column B, the code types 1 if you confirm an odd
number through the MsgBox, expecting the next number to be odd—
otherwise 2 for even.
Column C keeps track of the score: it adds 1, when your prediction
was correct—otherwise it subtracts 1.
Once you hit Cancel, a MsgBox tells you whether you won or lost, and
with which score.
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
What you need to do
Sub Guess()
Dim r As Long, iGuess As Integer, vGuess As
Variant, oRange As Range
Range("A1").CurrentRegion.Offset(1, 0).Delete
Do
r = Range("A1").CurrentRegion.Rows.Count + 1
vGuess = MsgBox("Odd (Yes), Even (No), Stop
(Cancel)", vbYesNoCancel)
Select Case vGuess
Case 6: Cells(r, 2) = 1
Case 7: Cells(r, 2) = 2
Case 2: GoTo Report
End Select
Cells(r, 1) = Int(Rnd * 50) + 1
Cells(r, 3) = IIf(Cells(r, 1) Mod 2 = Cells(r, 2)
Mod 2, Cells(r - 1, 3) + 1, Cells(r - 1, 3) - 1)
Loop
Report:
Set oRange =
Cells(Range("A1").CurrentRegion.Rows.Count, 3)
MsgBox "You " & IIf(oRange < 1, "lost", "won")
& " with a score of " & oRange
End Sub
Chapter 4: An X-O Game
What the simulation does
Sub IntelligentGame()
Dim oBoard As Range, bPlayer As Boolean, i As
Integer, oCell As Range
Dim iRow As Integer, iCol As Integer, iTime As
Long
Set oBoard = Range(Cells(1, 1), Cells(5, 5))
With oBoard
.Cells(1.1).CurrentRegion.Clear
.BorderAround , xlThick :
.Cells.HorizontalAlignment = xlCenter
Do
bPlayer = Not bPlayer
Do
iRow =
WorksheetFunction.RandBetween(1, 5)
iCol = WorksheetFunction.RandBetween(1,
5)
If .Cells(iRow, iCol) = "" Then
.Cells(iRow, iCol) = IIf(bPlayer, "X",
"O"): Exit Do
End If
Loop
iTime = Timer + 1
Do Until Timer > iTime
DoEvents
Loop
For i = 1 To 5
If
WorksheetFunction.CountIf(.Rows(i).Cells, "X") >=
1 And WorksheetFunction.CountIf(.Rows(i).Cells,
"O") >= 1 Then .Cells(i, 6) = "Lost"
If
WorksheetFunction.CountIf(.Columns(i).Cells, "X")
>= 1 And
WorksheetFunction.CountIf(.Columns(i).Cells, "O")
>= 1 Then .Cells(6, i) = "Lost"
Next i
If WorksheetFunction.CountIf(.Cells(1,
1).CurrentRegion.Cells, "Lost") = 10 Then MsgBox
"No winner": Exit Do
For i = 1 To 5
If
WorksheetFunction.CountIf(.Rows(i).Cells, "X") = 5
Then MsgBox "X is the winner.": iX = iX + 1: Exit
Do
If
WorksheetFunction.CountIf(.Rows(i).Cells, "O") = 5
Then MsgBox "O is the winner.": iO = iO + 1: Exit
Do
If
WorksheetFunction.CountIf(.Columns(i).Cells, "X")
= 5 Then MsgBox "X is the winner.": iX = iX + 1:
Exit Do
If
WorksheetFunction.CountIf(.Columns(i).Cells, "O")
= 5 Then MsgBox "O is the winner.": iO = iO + 1:
Exit Do
Next i
If WorksheetFunction.CountBlank(oBoard) =
0 Then MsgBox "No winner": Exit Do
Loop
End With
iTotal = iTotal + 1
MsgBox "X won " & iX & vbCr & "O won " & iO
& vbCr & "in " & iTotal & " games."
End Sub
Chapter 5: A Slot Machine
What the simulation does
This spreadsheet makes 20 runs for each game (columns F:H). Each
run creates 3 random numbers between -2 and +2, and then calculates the
cumulative total in column J. After 20 runs, a new game starts.
The results for each game are recorded in columns N and O. After 20
games, the average score features in cell R3. At any moment, the user can
cancel further runs and a MsgBox reports what the average score was in X
games of 20 runs. Then the process can start all over with run 1 for game 1.
What you need to know
To make all of this possible, we need a Do-loop for the runs inside a
Do-loop for the games. Besides we added a Timer loop so the results come
in gradually
To make the code more understandable, we used Range Names here
that were assigned in Excel. The range name “games,” for instance, refers to
the range $N$2:$N$21.
The VBA function FormatNumber lets you determine the number of
decimals by specifying the second argument.
Instead of using RANDBETWEEN(-2,2), we can use also: -2 +
Int(Rnd * 5).
What you need to do
Option Explicit
Sub Run()
Dim iRun As Integer, iGame As Integer, pTime As
Long
Range(Cells(2, 1), Cells(21, 18)).ClearContents
Do
iRun = iRun + 1
Do
iGame = iGame + 1
With Range("Runs")
.Cells(iGame, 1) = iGame
.Cells(iGame, 2) = -2 + Int(Rnd * 5)
.Cells(iGame, 3) = -2 + Int(Rnd * 5)
.Cells(iGame, 4) = -2 + Int(Rnd * 5)
Range("cumsums").Cells(iGame,
1).FormulaR1C1 = "=SUM(RC[-4]:RC[-2])"
End With
pTime = Timer + 0.5
Do While Timer < pTime
DoEvents
Loop
Loop Until iGame = 20
Range("run") = iGame
iGame = 0
Range("game") = iRun
Range("games").Cells(iRun, 1) = "Game " &
iRun
Range("gamescores").Cells(iRun, 1) =
Range("cumsums").Cells(20, 1)
Range("avgscore").Formula =
"=average(gamescores)"
If iRun = 20 Then Exit Do
Loop Until MsgBox("New run?", vbOKCancel) =
vbCancel
MsgBox "Average of " &
FormatNumber(Range("avgscore"), 1) & " in " &
iRun & " games of 20 runs"
End Sub
Chapter 6: Gamblers’ Ruin
What the simulation does
This sheet simulates what may happen to people who are addicted to
gambling. When we run the code, we are asked how many chances we want
in column A to go for odd or even. We simulate a 50% probability for either
choice. If the choice was correct, the count in column A goes up by 1,
otherwise it goes down by 1. All this is done on a new sheet.
Next we simulate that this addicted player repeats
the game for some twenty more times. This is done with a
Data Table in D:H (see Appendix). In its top row, we
calculate average, minimum, maximum, standard
deviation, and the final score (in column H). At the end,
we calculate how often the player had a positive final
score, and how often a negative one. Most of the work
goes into the conditional formatting bars.
What you need to know
Usually a Data Table has have a formula in the first cell—which
would be cell C1 in our case. Based on that formula, a Data Table typically
uses a row input of variables and a column input of variables to recalculate
the formula placed at its origin. It does so by filling the table cells with a
formula that has the following syntax: {=TABLE(row-input, col-input)}.
In this case we use a Data Table merely to trick Excel into simulating
20 (or many more) iterations of column A. We do so by not placing a
formula at the origin, but by leaving the row-input argument empty, and
having the col-input argument refer to an empty cell somewhere outside the
table. Yes, that does the trick!
By using Worksheet.Add we create a new worksheet either before (1st
argument) or after (2nd argument after the comma) the Activesheet, which is
the sheet we are currently on.
An InputBox provides users to provide their own input for variables
or questions.
What you need to do
Sub Gambling()
Dim oWS As Worksheet, iRow As Long
iRow = InputBox("How many rows?", , 100)
Set oWS = Worksheets.Add( , ActiveSheet)
Range("A1") = 0
Range(Cells(2, 1), Cells(iRow, 1)).Formula =
"=IF(RAND()>0.5,A1+1,A1-1)"
Range("D1") = "Average": Range("D2").Formula
= "=AVERAGE(A:A)"
Range("E1") = "Min": Range("E2").Formula =
"=MIN(A:A)"
Range("F1") = "Max": Range("F2").Formula =
"=MAX(A:A)"
Range("G1") = "SD": Range("G2").Formula =
"=STDEV(A:A)"
Range("H1") = "Final": Range("H2").Formula =
"=" & Cells(iRow, 1).Address(False, False)
Range(Range("C2"), Range("H22")).Table ,
Range("B2")
oRange.FormatConditions.Add(xlCellValue, xlLess,
"=0")
oFormat.Interior.Color = 13551615
www.Ebook777.com
Dim sMsg As String
sMsg = WorksheetFunction.CountIf(Columns(4),
">0") & " runs with average above 0"
sMsg = sMsg & vbCr & "Average of final scores: "
& FormatNumber(Range("H24"), 2)
MsgBox sMsg
End Sub
Chapter 7: Lottery Numbers
What the simulation does
Each time we run this macro, the code creates a 4-digit random
number in cell F1. Then it tries to match that number by creating new 4-digit
random numbers until the two numbers match.
After each match, it plots in column A how many times—how many
“tickets”—it took to find a match. The simulation keeps doing this until we
hit the No-button in the MsgBox.
What you need to know
Each random digit is generated by Int(Rnd * 10). The Int function
always rounds down to the nearest integer (0 – 9). But because this digit has
to be incorporated in the 4-digit lottery number, we need also the CStr
function which converts the number into a String.
To “string” things together, we always need [space][ampersand]
[space] between the individual strings that need to be “stringed” together.
Do-loops are perfect when we don’t know ahead of time how many
loops we need. The loop can be stopped by adding a While or Until
condition on the Do-line or the Loop-line. Another possibility is—which we
did here—using an IF-statement. If the condition of the If-statement kicks in,
we perform an Exit Do (not to be confused with an Exit Sub), which takes us
to the line after the Loop-statement.
What you need to do
Option Explicit
Sub Lottery()
Dim sNumber As String, sGuess As String, i As
Integer, j As Long, n As Long
Range("A1").EntireColumn.Clear
If MsgBox("New winning number?", vbYesNo) =
vbYes Then
sNumber = ""
For i = 1 To 4
sNumber = sNumber & CStr(Int(Rnd * 10))
Next i
Range("F1") = "'" & sNumber
Else
sNumber = Range("F1")
End If
Do
For i = 1 To 4
sGuess = sGuess & CStr(Int(Rnd * 10))
Next i
n=n+1
If CStr(sNumber) = CStr(sGuess) Then
j=j+1
Cells(j, 1) = "After " & n & " tickets."
Free ebooks ==> www.Ebook777.com
n=0
If MsgBox("Another run?", vbYesNo, sGuess)
= vbNo Then Exit Do
End If
sGuess = ""
Loop
End Sub
www.Ebook777.com
Chapter 8: Win or Lose?
What the simulation does
After each trial, the macro plots the current time in Column A, then a
random win or lose amount of money in column B, and a cumulative total of
what has been won or lost so far in column C.
When we decide to quit, a MsgBox reports to us how much we have
won or lost in total after an X number of trials.
What you need to know
The Now function returns the serial number of the current date and
time. If the cell format was General before the function was entered, Excel
changes the cell format so that it matches the date and time format of your
regional settings.
AutoFit widens the EntireColumn to its widest entry. It does so for the
entire sheet if you use Cells, or for a specific range on the sheet that you
specify—for instance, Cells(1,1).
FormulaR1C1 uses a row and column notation—for instance, R1C1—
instead of the more common notation of A1. To use this notation also in
Excel itself, you can go here: File | Options | Formulas | R1C1 reference
style.
FormulaR1C1 can have relative or absolute references. Here are
some examples: RC refers to the same row and column number as where the
cell itself is located; R1C1 refers to a cell in row 1 and column 1 (which is
A1); R[-1]C[1] refers to 1 row up and 1 column to the right of where the
reference is located (see Appendix).
FormatCurrency does something similar to what FormatNumber
does. It lets you specify the number of decimals in the 2nd argument, but it
also adds a currency symbol (which is a non-numeric entity).
What you need to do
Sub WinOrLose()
Dim i As Long, sMsg As String
Columns("A:C").ClearContents
Range("A1") = "Time": Range("B1") =
"WinOrLose": Range("C1") = "Total"
For i = 2 To 1000
Cells(i, 1) = Now
Cells(i, 2) = FormatCurrency(1 - 2 * Rnd, 2)
Cells(i, 3).FormulaR1C1 = "=SUM(R2C2:RC2)"
Cells.EntireColumn.AutoFit
If MsgBox("Another trial?", vbYesNo) = vbNo
Then Exit For
Next i
With Cells(i, 3)
If .Value >= 0 Then sMsg = "you WON: " Else
sMsg = "you LOST: "
MsgBox "After " & i - 1 & " trials " & sMsg &
FormatCurrency(Cells(i, 3), 2)
End With
End Sub
Free ebooks ==> www.Ebook777.com
The macro asks you first whether you want to use the 1st or the 2nd
sheet. The 2nd sheet uses “weighting”; the weight of each character is
assigned in column O. Then the macro asks which word should be found;
don’t make this more than 2 characters long, for that could be a very time-
consuming search.
In a Do-loop with two nested For-loops, the code scans all numbers
in B1:K10 until it finds the word you are looking for. Obviously, that goes
faster with “weighted” characters.
What you need to know
www.Ebook777.com
All capitals have an ASCI number between 65 and 90. The Excel
function CHAR returns the corresponding letter. Column M totals the scores
in column O cumulatively. So cell M2 has this formula: =SUM(O1:$O$1).
Now VLOOKUP can find a random number between 0 and 70 in column M,
and then return the corresponding letter from column N. VLOOKUP always
searches vertically, from top to bottom, in the first column of a table and
then finds a corresponding value in a column to the right, specified by a
number. So we need a lookup column of cumulative values before column
N. Besides, VLOOKUP looks for the previous value in an ascending order.
What you need to do
Option Explicit
Sub Letters()
Dim sWord As String, oRange As Range, c As
Integer, r As Integer, n As Integer, sFormula As String
Application.Calculation = xlCalculationManual
If MsgBox("Equal chars (Y) or weighted chars
(N)?", vbYesNo) = vbYes Then
Sheet1.Activate
sFormula =
"=CHAR(RANDBETWEEN(65,90))" '65-90 are the
capitals
Else
Sheet2.Activate
sFormula =
"=VLOOKUP(RANDBETWEEN(0,70),$M$1:$N$26,2)"
End If
Set oRange = Range("B1:K10")
oRange.ClearContents:
oRange.Interior.ColorIndex = 0
sWord = InputBox("Which 2-letter word?", ,
"NO")
sWord = UCase(Left(sWord, 2))
oRange.Cells.Formula = sFormula
With oRange
Do
Sheet1.Calculate
n=n+1
For r = 1 To .Rows.Count
For c = 1 To .Columns.Count
If .Cells(r, c) = Left(sWord, 1) Then
If c < .Columns.Count Then
If .Cells(r, c + 1) = Right(sWord,
1) Then Exit Do
'so this loop stops when it finds
one (the 1st) case
End If
End If
Next c
Next r
Loop Until MsgBox("Trial " & n & ": not
found! Try again?", vbYesNo) = vbNo
.Range(.Cells(r, c - 1), .Cells(r, c)).Interior.Color
= vbYellow
MsgBox "Found " & sWord & " after " & n & "
trials" & vbCr & _
"in cells " & .Cells(r, c).Address & "+"
& .Cells(r, c + 1).Address
End With
End Sub
Chapter 10: A Three-Way Circuit
What the simulation does
This is OFF:
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
What you need to do
Option Explicit
Sub Hits()
Dim b1 As Boolean, b2 As Boolean, b3 As Boolean,
b4 As Boolean
Dim iHit As Integer, n As Integer, sMsg As String
Do
If Rnd > 0.5 Then
Range("C4").Font.Color = vbBlack:
Range("C5").Font.Color = vbWhite
b1 = True: b2 = False
Else
Range("C4").Font.Color = vbWhite:
Range("C5").Font.Color = vbBlack
b1 = False: b2 = True
End If
If Rnd > 0.5 Then
Range("F4").Font.Color = vbBlack:
Range("F5").Font.Color = vbWhite
b3 = True: b4 = False
Else
Range("F4").Font.Color = vbWhite:
Range("F5").Font.Color = vbBlack
b3 = False: b4 = True
End If
n=n+1
If (b1 And b3) Or (b2 And b4) Then iHit = iHit +
1
sMsg = sMsg & "Runs: " & n & vbTab & "Hits:
" & iHit & vbTab & FormatPercent(iHit / n, 0) &
vbCr
MsgBox sMsg
Loop Until MsgBox("Again?", vbYesNo) = vbNo
End Sub
Chapter 11: Flocking Behavior
What the simulation does
Option Explicit
Sub FlockBehavior()
Dim oRange As Range, i As Integer, bWon As
Boolean, pTime As Double
Set oRange = Range("B2:K11")
oRange.ClearContents
Do
oRange.Formula =
"=VLOOKUP(RAND(),$M$2:$N$5,2)"
oRange.Formula = oRange.Value
pTime = Timer + 0.5 'Timer: secs since
midnight; pause by .5 seconds
Do While Timer < pTime
DoEvents
Loop
For i = 1 To 4
If Range("O1").Offset(i, 0) >= 35 Then bWon
= True: Exit For
Next i
Loop Until bWon = True
If bWon Then oRange =
WorksheetFunction.VLookup("+",
Range("$P$2:$Q$5"), 2, 0)
MsgBox "One direction"
End Sub
II. STATISTICS
Chapter 12: Samples
What the simulation does
The simulation first asks how many rows we want to plot on a new
sheet. Each cell in that range—in the above case range B2:K18—holds a
random number between 0 and 10. Columns O and P hold two frequency
tables. The top one calculates frequencies for row 2, which are the values
for a sample of 10 cases. The bottom one calculates frequencies for row 20,
which holds the averages of each column based on a sample of 17x10=170
cases.
It is to be expected that the frequency curve for the large sample
resembles more of a normal distribution than the curve for the small sample
of 10 cases. Below is the result of 25 rows.
What you need to know
The FREQUENCY function is a so-called array function. That means
in Excel, you have to select multiple cells at once and accept the formula
with Ctrl + Shift + Enter (on a Mac: Command + Return). In VBA you do
this by using the FormulArray property of a range of cells.
We also added two ChartObjects to the code and the sheet. They are
numbered in the order they were created: 1 and 2. Notice that
SetSourceData is followed by a space—yes, every minute detail counts in
VBA!
What you need to do
Option Explicit
Sub Samples()
Dim oWS As Worksheet, iRow As Long, oRange As
Range, oChart As Chart
iRow = InputBox("How many rows on a new
sheet?", , 25) + 2
Set oWS = Worksheets.Add(, ActiveSheet)
Range(Cells(2, 2), Cells(2, 11)).Formula =
"=INT(RAND()*11)"
Range(Cells(2, 2), Cells(2, 11)).Interior.Color =
vbYellow
Cells(2, 13).Formula = "=STDEV(B2:K2)"
Range(Range("A2"), Cells(iRow, 11)).Table ,
Range("A1")
Set oRange = Range(Cells(iRow + 2, 2), Cells(iRow
+ 2, 11))
oRange.FormulaR1C1 = "=AVERAGE(R[-2]C:R[-
" & iRow & "]C)"
oRange.Interior.Color = vbYellow
Cells(iRow + 2, 13).FormulaR1C1 =
"=STDEV(RC[-11]:RC[-2])"
Range("O2:O11").Formula = "=ROW(A1)"
Range("P2:P11").FormulaArray =
Free ebooks ==> www.Ebook777.com
"=FREQUENCY(B2:K2,O2:O11)"
Range("O14:O23") = "=ROW(A1)"
Range("P14:P23").FormulaArray =
"=FREQUENCY(" & oRange.Address &
",O14:O23)"
Range("O2:P11").Select
oWS.Shapes.AddChart2(240,
xlXYScatterLines).Select
ActiveChart.SetSourceData oWS.Range("O2:P11")
ActiveChart.HasTitle = False
oWS.ChartObjects(1).Top = Range("R2").Top
oWS.ChartObjects(1).Left = Range("R2").Left
oWS.ChartObjects(1).Width = 300
oWS.ChartObjects(1).Height = 150
Range("O14:P23").Select
oWS.Shapes.AddChart2(240,
xlXYScatterLines).Select
ActiveChart.SetSourceData
oWS.Range("O14:P23")
ActiveChart.HasTitle = False
oWS.ChartObjects(2).Top = Range("R14").Top
oWS.ChartObjects(2).Left = Range("R14").Left
oWS.ChartObjects(2).Width = 300
oWS.ChartObjects(2).Height = 150
Range("A1").Select
www.Ebook777.com
End Sub
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
The function NORMINV (or NORM.INV, if available) in column A
returns the inverse of the normal cumulative distribution for the specified
mean and standard deviation. The function NORMDIST in E returns the
normal distribution for the specified mean and standard deviation.
By replacing the Formula property of a range with its Value property,
we are mimicking a Paste Special procedure for values—so that things
don’t keep recalculating.
The Chart has two cases of a FullSeriesCollection, 1 and 2.
What you need to do
Option Explicit
Sub Bins()
Dim iSize As Integer, pMean As Double, pSD As
Double, iBins As String, oWS As Worksheet
iBins = 15
iSize = InputBox("New sheet: The size of your
sample:", , 100)
pMean = InputBox("New sheet: The mean of your
sample:", , 10)
pSD = InputBox("New sheet: The SD of your
sample:", , 0.2)
Set oWS = Worksheets.Add(, ActiveSheet)
Range(Cells(1, 1), Cells(iSize, 1)).Formula =
"=NORMINV(RAND()," & pMean & "," & pSD &
")"
Range(Cells(1, 1), Cells(iSize, 1)).Formula =
Range(Cells(1, 1), Cells(iSize, 1)).Value
Range("C1").Formula = "=MIN(A:A)"
Range("C2").Formula = "=MAX(A:A)"
Range(Cells(4, 3), Cells(3 + iBins, 3)).Formula =
"=$C$1+(ROW(A1))*(ROUND(($C$2-$C$1)/(" &
iBins & "),4))"
Range(Cells(4, 4), Cells(3 + iBins,
4)).FormulaArray = "=FREQUENCY(A:A," &
Range(Cells(4, 3), Cells(3 + iBins, 3)).Address & ")"
Range("E1") =
WorksheetFunction.Average(Columns(1))
Range("E2") =
WorksheetFunction.StDev(Columns(1))
Range(Cells(4, 5), Cells(3 + iBins,
5)).FormulaR1C1 =
"=NORMDIST(RC[-2],R1C5,R2C5,FALSE)"
Range("C4:E18").Select
oWS.Shapes.AddChart2(240,
xlXYScatterLines).Select
With ActiveChart
.SetSourceData Range("C4:E18")
.HasTitle = False
.FullSeriesCollection(1).ChartType =
xlColumnClustered
.FullSeriesCollection(2).ChartType = xlArea
.FullSeriesCollection(2).AxisGroup = 2
ActiveChart.Axes(xlCategory).TickLabels.NumberFormat
= "#,##0.00"
End With
Cells(1, 1).Select
End Sub
Chapter 14: Distribution Simulations
What the simulation does
www.Ebook777.com
Chapter 15: Discrete Distributions
What the simulation does
Let’s pretend you are a persistent, but very systematic, gambler. You
decide ahead of time how to spend your different kinds of banknotes, which
is specified in range D1:E5. The first columns in the chart display these
settings as well.
Then the macro lets the machine determine one hundred times, in
column A, when and which kind of banknotes to use and in which order.
This is a random process, but within the margins set in D1:E5. The results
are shown in the second columns of the chart.
Although the process is random, it follows a discrete distribution
which comes always very close to what you would expect.
What you need to know
For the Range E1:E5, the macro creates random percentages, which
together should make for 100%. That requires some math manipulation. Then
we need the function VLOOKUP to use these percentages to find the
corresponding type of banknote.
However, VLOOKUP always searches vertically, from top to bottom,
in the first column of a table, and then finds a corresponding value in a
column to the right, specified by a number. So we need a lookup column
before D1:D5 in order to determine the type of banknote to use. Besides,
VLOOKUP looks for the previous value in an ascending order, so it would
find $1 for all percentages between 0% and 60%, $5 between 60% and
80%, and $100 for percentages greater than or equal to 98%.
Therefore, we need cumulative totals in the first column (C), starting
at 0%. The third column (E) is now redundant, but is still needed for the
chart to the right in order to show the expected frequencies—versus the
randomly generated frequencies.
Free ebooks ==> www.Ebook777.com
Option Explicit
Sub Distribution()
Dim i As Integer, arr() As Integer, n As Integer
ReDim arr(4)
n = WorksheetFunction.RandBetween(0, 60)
arr(0) = n - (n Mod 5)
n = WorksheetFunction.RandBetween(0, 100 -
arr(0))
arr(1) = n - (n Mod 5)
n = WorksheetFunction.RandBetween(0, 100 -
(arr(0) + arr(1)))
arr(2) = n - (n Mod 5)
n = WorksheetFunction.RandBetween(0, 100 -
(arr(0) + arr(1) + arr(2)))
arr(3) = n - (n Mod 5)
arr(4) = 100 - (arr(0) + arr(1) + arr(2) + arr(3))
For i = 0 To 4
Cells(i + 1, 5) = FormatPercent(arr(i) / 100, 0)
Next i
Range("C2:C5").Formula = "=SUM($E$1:E1)"
Range("A1:A100").Formula =
"=VLOOKUP(RAND(),$C$1:$D$5,2)"
End Sub
www.Ebook777.com
Chapter 16: Peaks
What the simulation does
In a module:
Option Explicit
Sub StopLooping()
bStopMacro = True
End Sub
www.Ebook777.com
What you need to do
Option Explicit
www.Ebook777.com
Chapter 18: Sample Size and
Confidence Interval
What the simulation does
This sheet has two macros. The first macro (see above) simply asks
for input variables and calculates confidence intervals.
The second macro (see below) calculates how many cases you would
need in your sample in order to reach a specific margin limit.
What you need to know
The WorksheetFunction T_Inv_2T returns the t-value of the Student t-
distribution as a function of the probability and the degrees of freedom. The
degrees of freedom are the number of cases minus 1. The t-value works for
all sample sizes, even under 32.
The Standard Error (SE) is the Standard Deviation (SD) divided by
the SQRT of the number of cases. So the confidence margin is the Standard
Error times the t-value.
The 2nd macro uses Excel’s GoalSeektool that allows you to alter
data in formulas to get a specific result that you want to reach by changing a
specific value (here B2, in the 2nd argument).
What you need to do
Option Explicit
Sub ConfidenceIntervalI()
Dim pValue As Double, iCases As Long, pSE As
Double, pPerc As Double
Dim pTInv As Double, pMin As Double, pMax As
Double, pMargin As Double
On Error Resume Next
pValue = InputBox("Which value?", , 5.5)
iCases = InputBox("How many cases?", , 30)
pSE = InputBox("SD", , 0.5) / Sqr(iCases)
pPerc = InputBox("Confidence", , 0.95)
pTInv = WorksheetFunction.T_Inv_2T(1 - pPerc,
iCases - 1)
pMargin = pSE * pTInv
pMin = FormatNumber(pValue - pMargin, 3)
pMax = FormatNumber(pValue + pMargin, 3)
MsgBox pPerc * 100 & "% confidence: " & vbCr
& "between " & pMin & " and " & pMax
End Sub
Sub SampleSize()
Dim pConf As Double, pGoal As Double, iRow As
Integer, sAddr As String, sMsg As String
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Chapter 19: Random Repeats
What the simulation does
Option Explicit
Sub NewSample()
Dim oWS As Worksheet, oRange As Range, oChart
As ChartObject
Dim pMean As Double, pSD As Double
On Error GoTo Trap
pMean = InputBox("The new mean on a new
sheet:", , 50)
pSD = InputBox("The new SD:", , 10)
Set oWS = ActiveSheet
oWS.Copy , Sheets(Sheets.Count)
Set oRange =
ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
oRange.Columns(2).Formula =
"=NORMINV(RAND()," & pMean & "," & pSD &
")"
If MsgBox("Keep formulas for F9?", vbYesNo) =
vbNo Then
oRange.Columns(2).Formula =
oRange.Columns(2).Value
End If
Range("B2").Comment.Text "A mean of " &
pMean & " and SD of " & pSD & "."
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Chapter 20: Flipping a Fair Coin?
What the simulation does
www.Ebook777.com
What you need to do
Option Explicit
Sub Coins()
Dim oWS As Worksheet
Set oWS = ActiveSheet
oWS.Copy , Sheets(Sheets.Count)
Range("C2:G8,C11:F16,C18:F18,R2:U18,R20:U20").ClearCon
Range("A1").Select
MsgBox "The chances for X (head) if the coin is 20
to 50% fair:"
Range("C2:G8").Formula =
"=BINOMDIST($B2,6,C$1,0)"
MsgBox "Flip these coins 6 times randomly:"
Range("C11:F16").Formula = "=IF(RAND()
<=C$10,""X"",""0"")"
MsgBox "Here are the chances of X for each coin:"
Range("C18:F18").Formula =
"=COUNTIF(C11:C16,""X"")/6"
MsgBox "Then we repeat these calculations 17
times:"
Range("R2:U2").Formula = "=C18"
Range("Q2:U18").Table , Cells(100, 100)
MsgBox "How often did we hit 50% chance of
head vs. tail?"
Range("R20:U20").Formula =
"=COUNTIF(R2:R18,0.5)"
End Sub
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
CRITBINOM in pre-2010 versions. It has 3 arguments: the number of trials,
the probability of a success on each trial, and the criterion value (alpha).
The function IFERROR is also quite recent (ISERROR could be used
in earlier versions, but is a bit mpore involved). If there is an error in a
certain BINOMDIST calculation, it should display an empty string—which
calls for four double quotes (a string inside a string).
What you need to do
Option Explicit
Sub SickCases()
Dim iSize As Integer, iSick As Integer
iSize = InputBox("What is the sample size?", , 100)
Range("B1") = iSize
Range("B5:B15").Formula =
"=BINOM.INV($B$1,$A5,1-$B$2)"
Range("C5:C15").Formula =
"=BINOM.INV($B$1,$A5,$B$2)"
iSick = InputBox("How many sick cases?", , iSize /
4)
Range("G1") = iSick
Range("G5:G15").Formula = "=IFERROR(1-
BINOMDIST(G$1,$B$1,$F5,TRUE),"""")"
If MsgBox("Empty calculated cells?", vbYesNo) =
vbYes Then
Range("B1") = ""
Range("B5:B15") = ""
Range("C5:C15") = ""
Range("G1") = ""
Range("G5:G15") = ""
End If
End Sub
Chapter 22: Unbiased Sampling
What the simulation does
When taking samples, the problem is that some are more likely to be
chosen than others—so we call them biased samples. Unbiased sampling
requires some bias-proof techniques. Therefore, we need the unbiased
verdict of mathematical tools.
In this simulation, we use four different techniques to select telephone
area codes at random. Technique #1 assigns a random number, sorts by that
number, and then takes the first or last N cases. Technique #2 selects X% of
the area codes randomly. Technique #3 produces N cases randomly.
Technique #4 “weighs” each area code (say, depending on population
density) and then performs a weighted sampling of N cases.
The simulation scrolls through these four different techniques of
unbiased sampling.
What you need to know
Case #1 sorts the random numbers after their formulas have been
changed into values. The Sort method has many optional arguments. The 1st
argument specifies the first sort field, either as a range name (String) or
Range object; it determines the values that need to be sorted. The 2nd
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
What you need to do
Option Explicit
Sub RandomSelect()
Dim oRange As Range, iSize As Integer
If MsgBox("Sort all areacodes randomly",
vbYesNo) = vbNo Then Exit Sub
Range("B4:B270").Formula = "=RAND()"
Range("B4:B270").Formula =
Range("B4:B270").Value
Range("A4:B270").Sort Range("B4")
End Sub
Chapter 23: Transforming a
LogNormal Distribution
What the simulation does
Option Explicit
Sub TransformLogNormal()
Dim oWS As Worksheet
Set oWS = ActiveSheet
oWS.Copy , Sheets(Sheets.Count)
Range("A2:A101").Clear:
Range("B2:B101").Clear: Range("G2:G101").Clear
If MsgBox("Create a random LogNormal
Distribution?", vbYesNo) = vbNo Then
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
Exit Sub
End If
Range("A2:A101").Formula =
"=LOGNORM.INV(RAND(),2,0.5)"
Range("B2:B101").Formula =
"=LOGNORM.DIST(A2,$E$1,$E$2,TRUE)"
If MsgBox("Transform the data?", vbYesNo) =
vbNo Then Exit Sub
Range("G2:G101").Formula = "=LN(A2)"
MsgBox "Lognormal is " & IIf(Range("E4") =
"Y", "", "not ") & _
"significantly skewed: " & Range("E3") &
vbCr & "After transformation " & _
IIf(Range("E35") = "Y", "slightly ", "no
longer ") & _
"skewed: " & Range("E34") & ""
End Sub
Chapter 24: Outlier Detection
What the simulation does
Outliers are defined as numeric values in any random data set that
have an unusually high deviation from either the statistical mean or the
median value. In other words, these numbers are relatively extreme. It
requires sound statistics—not intuition—to locate them. A rather simple rule
is that all values outside a range of three times the standard deviation around
the mean could be considered outliers—provided they follow a normal
distribution.
What you need to know
In this simulation, however, we will use a more robust statistical
detection of outliers by calculating the deviation for each number, expressed
as a “modified Z-score,” and testing it against a predefined threshold. Z-
scores stand for the amount of standard deviation relative to the statistical
median (in D1). MAD (in D2) stands for Median Absolute Deviation. Any
number in a data set with the absolute value of modified Z-scores
exceeding 3.5 times MAD is considered an outlier.
Column D shows the outcome.
In the 1970’s the famous statistician John Tukey decided to give the
term outlier a more formal definition. He called any observation value an
outlier if it is smaller than the first quartile (F1) minus 1.5 times the IQR
(F3), or larger than the third quartile (F2) plus 1.5 times the IQR. The Inter-
Quartile Range, IQR, is the width of the interval that contains the middle half
of the data. Column F shows the outcome.
The graph to the right shows the observed values marked with a
square shape if it is an outlier according to the first method, or with a
diamond shape if it is an outlier according to the second method. Most of the
time, the first method detects more outliers than the second one.
What you need to do
Option Explicit
Sub Outliers()
Dim oWS As Worksheet
Set oWS = ActiveSheet
oWS.Copy , Sheets(Sheets.Count)
Range("B5:B29").Formula =
"=NORMINV(RAND(),30,15)*(1-2*RAND())"
Range("D5:D29").Formula = "=IF(ABS(D$1-B5)>
(3.5*D$2), ""outlier"", """")"
Range("F5:F29").Formula = "=IF(OR(B5>
($F$2+1.5*$F$3),B5<($F$1-
1.5*$F$3)),""OUTLIER"","""")"
Range("D5:D29,F5:F29").FormatConditions.Add
xlExpression, ,
"=AND($D5=""outlier"",$F5=""OUTLIER"")"
Range("D5:D29,F5:F29").FormatConditions(1).Interior.Color
= vbYellow
End Sub
Chapter 25: Bootstrapping
What the simulation does
When you have a series of values that are not normally distributed—
say, 30 values such as in column A—it is not so simple to calculate a mean,
a median, a SD, or a margin. You need some kind of technique such as
bootstrapping.
This sheet uses that technique by randomly selecting values from the
sample in A. We do that, for instance, 15 times: first in column D, then in
column E, and so on until column R. At the bottom of each column we
calculate the average. Based on these averages, we are able to know what
the statistical parameters are that we were looking for.
In the VBA code, we do all of this, not 15 times, but 1,000 times by
storing the results of each drawing in an array, from which we calculate the
bootstrapping results. Larger number of drawings are obviously less
susceptible to random fluctuations. A MsgBox reports what the outcome is
(see picture on the next page).
What you need to know
The Excel function INDEX is a more sophisticated version of
VLOOKUP. It looks in a table at a certain row position and a certain column
position. It uses this syntax: INDEX(table, row#, col#). Whereas VLOOKUP
works only with column numbers, INDEX also uses row numbers, which is
very important when we want to look at a record that is located a certain
number of rows above or below another record.
Each cell in D1:R30 has this:
=INDEX($A$1:$A$30,ROWS($A$1:$A$30)*RAND()+1)
In cell U2 is the mean of means: =AVERAGE(D32:R32)
In cell U3 is the number of samples: =COUNT(D32:R32)
In cell U4 is the 2.5% cut off: =U3*0.025
In cell U5 is the lower bound:
=SMALL($D$32:$R$32,ROUNDUP($U$4,0))
In cell U6 is the upper bound:
=LARGE($D$32:$R$32,ROUNDUP($U$4,0)):
What you need to do
Option Explicit
Sub BootStrap()
Dim i As Long, r As Long, j As Long, oRange As
Range, sMsg As String
Dim pValue As Double, pMean As Double, pSE As
Double, iCutOff As Integer, pMargin As Double
Dim arrMeans() As Double, arrValues() As Double
r = Range("A1").CurrentRegion.Rows.Count
Set oRange = Range(Cells(1, 1), Cells(r, 1))
ReDim arrMeans(1 To 1000)
For j = 1 To 1000
ReDim arrValues(1 To r)
For i = 1 To r
arrValues(i) =
WorksheetFunction.Index(oRange, r * Rnd() + 1)
Next i
arrMeans(j) =
WorksheetFunction.Average(arrValues)
Next j
iCutOff = WorksheetFunction.RoundUp(100 *
0.025, 0)
pMean =
Format(WorksheetFunction.Average(arrMeans),
"0.00")
pSE =
Format(WorksheetFunction.StDev_S(arrMeans),
"0.00")
pMargin = Format(pSE *
WorksheetFunction.T_Inv_2T(0.05, r - 1), "0.00")
sMsg = "Based on 1000 runs:" & vbCr
sMsg = sMsg & "Mean of the arrMeans: " &
pMean & vbCr
sMsg = sMsg & "SE of the arrMeans: " & pSE &
vbCr
sMsg = sMsg & "Margin at 95%: " & pMargin &
vbCr
sMsg = sMsg & "Lower Bound: " & pMean -
pMargin & vbCr
sMsg = sMsg & "Upper Bound: " & pMean +
pMargin
MsgBox sMsg
End Sub
Chapter 26: Bean Machine
Simulation
What the simulation does
Sub Beans()
Dim oStart As Range, oPrev As Range, oNext As
Range, c As Integer, r As Integer
Set oStart = Range("L1")
oStart.Interior.ColorIndex = 15
Set oPrev = oStart
For r = 1 To 10
If Rnd > 0.5 Then c = c + 1 Else c = c - 1
Set oNext = oStart.Cells.Offset(r, c)
oNext = oNext + 1
oNext.Interior.ColorIndex = 15
oPrev.Interior.ColorIndex = 0
Set oPrev = oNext
Next r
End Sub
Place on Sheet1:
Option Explicit
When you create multiple distributions, you may want to make this
happen with a specific correlation coefficient between them. This simulation
does so for you. In columns A:B, the macro creates two sets of normally
distributed values in columns A and B. However, we want these two sets (X
and Z) to be correlated as requested by cell E2. This simulation does so by
using a transformation with the formula mentioned above. Then, in a
MsgBox, it compares the old correlation coefficient with the new one.
What you need to know
When there are not 2 but 3 sets involved, you could hit Ctrl + Shift +
D, which does the following. It performs the so-called Cholensky
decomposition with a customized array function (see VBA-code), and then
converts your three sets of values by using the array function results with
another array formula like this: =MMULT(A2:C31,TRANSPOSE(F8:H10)).
MMULT returns the matrix product of two arrays, with one of them
transposed by using the TRANSPOSE function.
What you need to do
Sub Correlation()
Dim oRange As Range
Sheet2.Select
Set oRange = Range("A2:C31"):
oRange.ClearContents
MsgBox "First randomized values for X, Y, and Z"
oRange.Formula =
"=ROUND(NORMINV(RAND(),10,2),2)"
Set oRange = Range("F8:H10"):
oRange.ClearContents
MsgBox "Now the Cholensky Decomposition in
F8:H10"
oRange.FormulaArray = "=Cholenksy(F3:H5)"
'see function below
Set oRange = Range("J2:L31"):
oRange.ClearContents
MsgBox "Now the matrix manipulation in J2:L31"
oRange.FormulaArray =
"=MMULT(A2:C31,TRANSPOSE(F8:H10))"
End Sub
Sub Decomposition()
Dim oRange As Range
Sheet2.Select
Set oRange = Range("A2:C31"):
oRange.ClearContents
MsgBox "First randomized values for X, Y, and Z"
oRange.Formula =
"=ROUND(NORMINV(RAND(),10,2),2)"
Set oRange = Range("F8:H10"):
oRange.ClearContents
MsgBox "Now the Cholensky Decomposition in
F8:H10"
oRange.FormulaArray = "=Cholenksy(F3:H5)"
'see function below
Set oRange = Range("J2:L31"):
oRange.ClearContents
MsgBox "Now the matrix manipulation in J2:L31"
oRange.FormulaArray =
"=MMULT(A2:C31,TRANSPOSE(F8:H10))"
End Sub
Option Explicit
Sub Numbers()
Dim iLot As Integer, iSample As Integer
Sheet1.Select
Range("A1:B100,E6:N15").ClearContents
iLot = InputBox("Lot size (max of 100)", , 25): If
iLot > 100 Then Exit Sub
iSample = InputBox("Sample size (max of 100)", ,
15): If iLot > 100 Then Exit Sub
Range("G1") = iLot: Range("G2") = iSample
Range("A1:A100").Formula =
"=IF(ROW(A1)>$G$1,"""",RAND())"
Range("B1:B100").Formula =
"=IF(A1="""","""",IF(RANK(A1,$A$1:$A$101)>$G$2,"""",R
Range("E6:N15").Formula =
"=IF($D6+E$16>$G$2,"""",SMALL($B$1:$B$100,$D6+E$16))
Do
Calculate
Loop Until MsgBox("Again?", vbYesNo) = vbNo
End Sub
Sub Dates()
Dim iLot As Integer, iSample As Integer
Sheet2.Select
Range("A1:B100,F5:O14,F18:O27").ClearContents
iLot = InputBox("Lot size (max of 100)", , 25): If
iLot > 100 Then Exit Sub
iSample = InputBox("Sample size (max of 100)", ,
15): If iLot > 100 Then Exit Sub
Range("G1") = iLot: Range("G2") = iSample
Range("A1:A100").Formula =
"=IF(ROW(A1)>$G$1,"""",RAND())"
Range("A1:A100").EntireColumn.Hidden = True
Range("B1:B100").Formula =
"=IF(A1="""","""",IF(RANK(A1,$A$1:$A$100)>$G$2,"""",R
Range("B1:B100").EntireColumn.Hidden = True
Range("F5:O14").Formula =
"=IF($E5+F$15>$G$2,"""",SMALL($B$1:$B$100,$E5+F$15))"
Range("F18:O27").Formula =
"=IF($E5+F$15>$G$2,"""",SMALL($B$1:$B$100,$E5+F$15))"
Do
Calculate
Loop Until MsgBox("Again?", vbYesNo) = vbNo
End Sub
Chapter 29: Frequencies
What the simulation does
There is not much new in this simulation. It asks for a specific mean
and SD, loops for a specific amount of runs, creates a frequency table, and
then replaces the chart with a new one.
What you need to know
What you need to do
Option Explicit
Sub Frequencies()
Dim pMean As Double, pSD As Double, pArr() As
Double, i As Long
ActiveSheet.Shapes(2).Delete
pMean = InputBox("Mean", , Cells(2, 1))
pSD = InputBox("SD", , Cells(2, 2))
Cells(2, 1) = pMean: Cells(2, 2) = pSD
Cells(5, 1) = pMean - 4 * pSD
Cells(6, 1) = pMean - 3 * pSD
Cells(7, 1) = pMean - 2 * pSD
Cells(8, 1) = pMean - 1 * pSD
Cells(9, 1) = pMean
Cells(10, 1) = pMean + 1 * pSD
Cells(11, 1) = pMean + 2 * pSD
Cells(12, 1) = pMean + 3 * pSD
Cells(13, 1) = pMean + 4 * pSD
For i = 1 To InputBox("Runs", , 10000)
ReDim Preserve pArr(i)
pArr(i) = WorksheetFunction.Norm_Inv(Rnd,
pMean, pSD)
Next i
pMean = WorksheetFunction.Average(pArr)
pSD = WorksheetFunction.StDev_S(pArr)
Range("B5:B13") =
WorksheetFunction.Frequency(pArr,
Range("$A$5:$A$13"))
Range("A5:B13").Select
ActiveSheet.Shapes.AddChart2(240,
xlXYScatterSmooth).Select
ActiveChart.SetSourceData Range("A5:B13"):
ActiveChart.HasTitle = False
Range("A1").Select
MsgBox "After " & i - 1 & " runs:" & vbCr &
"Mean = " & _
FormatNumber(pMean, 3) & vbCr & "SD
= " & FormatNumber(pSD, 3)
End Sub
III. MONTE CARLO SIMULATIONS
Chapter 30: The Law of Large
Numbers
What the simulation does
Option Explicit
Sub Repeating()
Dim i As Integer, vArr As Variant, arrTotals() As
Long
Dim iRepeats As Integer, n As Integer, iTime As
Long
iTime = Timer
Range("G19:O19").ClearContents
iRepeats = InputBox("How many repeats?", , 100)
Cells(1, 1).Select
ReDim arrTotals(1 To 9)
For i = 1 To iRepeats
ActiveSheet.Calculate
vArr = Range("G13:O13")
For n = 1 To UBound(vArr, 2)
arrTotals(n) = arrTotals(n) + Int(vArr(1, n))
Range("G19:O19").Cells(1, n) =
Int(arrTotals(n) / i)
Range("G15") = iRepeats - i & " runs left"
Next n
Next i
Range("F18") = iRepeats & "x10,000 runs:"
MsgBox iRepeats & "x10,000 runs took " &
Int(Timer - iTime) & " seconds."
End Sub
Chapter 31: Brownian Motion
What the simulation does
Option Explicit
Sub Returning()
Dim i As Integer, oRange As Range, bBack As
Boolean, n As Long
Range("O3:Q32").Table , Range("N1")
Range("A1").Select
Set oRange = Range("P3:Q32")
'oRange.FormatConditions.Add xlExpression, ,
"=AND(AND($P3>=0,$P3<0.05),AND($Q3>=0,$Q3<0.05))"
'oRange.FormatConditions(1).Interior.Color =
vbYellow
Do While bBack = False
Calculate
For i = 1 To 30
If oRange.Cells(i, 1) > -0.03 And
oRange.Cells(i, 1) < 0.03 Then
If oRange.Cells(i, 2) > -0.03 And
oRange.Cells(i, 2) < 0.03 Then bBack = True: Exit Do
End If
Next i
n=n+1
Loop
MsgBox "Back to 0 at the " & i & "th run after "
& n & " repeats of 30 runs."
End Sub
Chapter 32: Ehrenfest Urn
What the simulation does
Option Explicit
Sub Equilibrium()
Dim oRange As Range, iRow As Long, iCol As
Integer
Set oRange = Range("A1").CurrentRegion
With oRange
iRow = WorksheetFunction.RandBetween(1, 8)
iCol = WorksheetFunction.RandBetween(1, 8)
If .Cells(iRow, iCol) = "X" Then .Cells(iRow,
iCol) = "O" Else .Cells(iRow, iCol) = "X"
Range("J1").Offset(i) =
WorksheetFunction.CountIf(oRange, "X")
Range("K1").Offset(i) =
WorksheetFunction.CountIf(oRange, "O")
i=i+1
End With
Do While i < 200
Equilibrium
Loop
End Sub
Sub Reset()
Dim oRange As Range
Set oRange = Range("A1").CurrentRegion
oRange.Cells = "X"
Columns(10).Clear
Columns(11).Clear
i=0
End Sub
Chapter 33: Random Walk
What the simulation does
Option Explicit
Sub Walking()
Dim oRange As Range, i As Integer, sBack As
String, sEndScores As String
Set oRange = Range("B3:C52")
With oRange
.Columns(1).ClearContents
.Columns(2).ClearContents
.Columns(1).FormulaR1C1 = "=IF(RAND()
<0.5,R[-1]C-1,R[-1]C+1)"
.Columns(2).FormulaR1C1 = "=IF(RAND()
<0.5,R[-1]C-1,R[-1]C+1)"
' .FormatConditions.Add xlExpression, ,
"=AND($B3=0,$C3=0)"
' .FormatConditions(1).Interior.Color = vbYellow
End With
Range("N3:N21").Formula =
"=IF(AND(O3=0,P3=0),0,NA())"
Set oRange = Range("O2:P21")
' oRange.FormatConditions.Add xlExpression, ,
"=AND($O2=0,$P2=0)"
' oRange.FormatConditions(2).Interior.Color =
vbYellow
sBack =
WorksheetFunction.CountIfs(Range("B3:B52"), 0,
Range("C3:C52"), 0) & _
"x back to a position of 0,0 during 1st
run"
sEndScores =
WorksheetFunction.CountIfs(Range("O2:O21"), 0,
Range("P2:P21"), 0) & _
"x back to start position 0,0 in 20 runs"
If MsgBox(sBack & vbCr & sEndScores & vbCr &
"Try again?", vbYesNo) = vbYes Then Walking
End Sub
Chapter 34: A Data Table with
Memory
What the simulation does
Option Explicit
Sub Memorize()
Dim oRange As Range, i As Integer, pPercent As
Double, sMsg As String
Dim arrTable As Variant, arrMin As Variant,
arrMax As Variant, arrPerc As Variant
Range("F2:G10").ClearContents
pPercent = InputBox("The chance for 1's is:", ,
0.1)
If pPercent > 1 Then MsgBox "Must be between 0
and 1": Exit Sub
Again:
Application.ScreenUpdating = False
Range("A1:A1000").Formula = "=IF(RAND()<="
& pPercent & ",1,0)"
Range("C1") = FormatPercent(pPercent, 2)
For i = 1 To 9
Range("C2:C10").Cells(i, 1) = pPercent + i / 100
Next i
Range("D1").Formula = "=COUNTIF(A:A,1)"
Set oRange = Range("C1:D10")
oRange.Table , Range("C1")
Calculate
www.Ebook777.com
arrPerc = Range("C2:C10")
arrTable = Range("D2:D10")
If IsEmpty(arrMin) Then
arrMin = Range("D2:D10")
arrMax = Range("D2:D10")
Else
For i = 1 To 9
If arrTable(i, 1) < arrMin(i, 1) Then arrMin(i,
1) = arrTable(i, 1)
If arrTable(i, 1) > arrMax(i, 1) Then arrMax(i,
1) = arrTable(i, 1)
Next i
End If
sMsg = "Percent" & vbTab & "Min" & vbTab &
"Max" & vbCr
For i = 1 To 9
sMsg = sMsg & arrPerc(i, 1) & vbTab &
arrMin(i, 1) & vbTab & arrMax(i, 1) & vbCr
Next i
Application.ScreenUpdating = True
MsgBox sMsg
If MsgBox("Keep running?", vbYesNo) = vbYes
Then GoTo Again
End Sub
Chapter 35: Juror Selection in Court
What the simulation does
Countries with a juror system in court have to face the fact that they
must choose 2x12 jurors from a larger pool of candidates after checking
each candidate for certain criteria.
We assume we need 24 jurors (cell E1) from a pool of 100 (cell B1).
We also use the following criteria: #1 they have no opinion yet whether the
defendant is guilty (column B); #2 they were not witness to the crime
(column C); #3 they accept the possibility of the death penalty (column D).
These criteria have a probability in the population as shown in range B4:D4.
Column E decides whether all three conditions have been met. Cell F4
counts how many in the pool of candidates actually qualified to be a juror in
the case.
Finally we run this setup with a Data Table repeated 10 times (G:H,
I:J, up to Y:Z); each one running pool sizes from 100 to 1000. We average
these results in column AC, and we mark pool sizes that meet the needed
number of candidates (F2) with Conditional Formatting.
What you need to know
All gray cells have a formula in it. This is done by selecting all cells
and implementing Condition Formatting based on this formula:
=ISFORMULA(A1).
In the run shown below, a pool of 100 or 150 candidates would not be
enough to reach the 24 jurors needed, given the three conditions in B:D and
their probabilities. But 200 would! Again, we are dealing with probabilities
here, so results may vary!
What you need to do
Option Explicit
Sub Jurors()
Dim iCand As Integer, iNeeded As Integer, i As
Integer, oRange As Range
Application.ScreenUpdating = False
Range("H4,J4, L4, N4, P4, R4,
T4,V4,X4,Z4,AC4").EntireColumn.ClearContents
Set oRange = Range("A5:E1005")
oRange.ClearContents
Range("H5:H23").ClearContents
Application.ScreenUpdating = True
Range("B1") = InputBox("How many
candidates?", , 100)
Range("E1") = InputBox("How many jurors
needed?", , 24)
With oRange
.Columns(1).Formula = "=IF(ROW(A1)
<=$B$1,TEXT(ROW(A1), ""Juror 0""),"""")"
.Columns(2).Formula = "=IF(ROW(A1)
<=$B$1,IF(RAND()<B$4,""+"",""""),"""")"
.Columns(3).Formula = "=IF(ROW(B1)
<=$B$1,IF(RAND()<C$4,""+"",""""),"""")"
.Columns(4).Formula = "=IF(ROW(C1)
<=$B$1,IF(RAND()<D$4,""+"",""""),"""")"
.Columns(5).Formula =
"=IF(COUNTIF(B5:D5,""+"")=3,1,0)"
End With
Application.ScreenUpdating = False
Range("H4,J4, L4, N4, P4, R4,
T4,V4,X4,Z4").Formula = "=SUM($E$5:$E$1005)"
With Range("G4:R23")
For i = 2 To 20 Step 2
.Range(Cells(1, i - 1), Cells(20, i)).Table ,
Range("B1")
'to prevent each table from recalculating,
replace with values:
.Range(Cells(1, i - 1), Cells(20, i)).Formula =
.Range(Cells(1, i - 1), Cells(20, i)).Value
Next i
End With
Range("AC5:AC23").Formula =
"=INT(AVERAGE(H5,J5,L5,N5,P5,R5,U5,T5,V5,X5,Z5))"
Application.ScreenUpdating = True
End Sub
Chapter 36: Running Project Costs
What the simulation does
The number of runs (J6) is determined by the values in the cells above
it: ((1.96/(margin/mean)) ^ 2) * ((SD/mean) ^ 2)
The mean (J1) is: =AVERAGE(G2:G3).
The Standard Deviation (J2) is: =STDEVP(G2:G3,J1).
The Margin (J3) is: =J1/300.
The Z or t value for 95% confidence is approximately 1.96.
What you need to do
Option Explicit
Sub ProjectCosts()
Dim i As Integer, iRuns As Long
Dim oWS As Worksheet, oRange As Range, oCell
As Range
iRuns = Range("J6") 'Formula:
((1.96/(margin/mean)) ^ 2) * ((SD/mean) ^ 2)
ActiveSheet.Copy , Sheets(Sheets.Count)
Application.Calculation = xlCalculationManual
Set oRange = Range(Range("B9"),
Range("B9").Cells(iRuns, 5))
oRange.Formula = "=RAND()*(B$2-B$3)+B$3"
Set oRange = Range(Range("G9"),
Range("G9").Cells(iRuns, 1))
oRange.Formula = "=SUM(B9:F9)"
Range("B5:G5").FormulaR1C1 =
"=average(R[4]C:R[" & iRuns + 3 & "]C)"
Range("A5") = "average"
Range("B6:G6").FormulaR1C1 = "=R[-1]C +
1.96* stdev(R[3]C:R[" & iRuns + 2 & "]C)"
Range("A6") = "upper bound"
Range("B7:G7").FormulaR1C1 = "=R[-2]C - 1.96*
stdev(R[2]C:R[" & iRuns + 1 & "]C)"
Range("A7") = "lower bound"
Application.Calculation = xlCalculationAutomatic
Cells.EntireColumn.AutoFit
MsgBox "Based on " & iRuns & " iterations"
Range("B5:G7").Formula =
Range("B5:G7").Value
If MsgBox("Delete the calculations that were
generated?", vbYesNo) = vbYes Then
Range(Range("B9"), Range("B9").Cells(iRuns,
6)).ClearContents
End If
End Sub
Free ebooks ==> www.Ebook777.com
Let’s say we are trying to the figure out the optimal amount of
production needed in order to maximize our profits. If the demand for this
product is regulated by a range of probabilities, then we can determine our
optimal production by simulating demand within that range of probabilities
and calculating profit for each level of demand.
The simulation uses three tables to set up this calculation. The table top
right (E:F) sets up the assumed probabilities of various demand levels. The
table top left (A:B) calculates the profit for one trial production quantity.
Cell B1 contains the trial production quantity. Cell B2 has a random number.
In cell B3, we simulate demand for this product with the function
VLOOKUP.
The third table, on the lower left, is a Data Table which simulates
each possible production quantity (20,000, 30,000, to 70,000) some 1,000
times and calculates profits for each trial number (1 to 1,000) and each
production quantity (10,000, etc.).
Finally, row 13 calculates the mean profit for the six different
production quantities. In this example, the figures show that a production of
www.Ebook777.com
40,000 units results in maximum profits.
The VLOOKUP function in B3 matches the value in B1 with the
closest previous match in the first column of table D2:E5; column D has
cumulative totals.
In cell A18 starts a Data Table. A18 has a link to the profit in B11.
Then it uses cell B1 (20,000) for the row input, and an empty cell (say, H12)
for the column input.
What you need to know
The VBA code creates each time a new sheet and plots range
A13:H16 six times (after recalculation) on this new sheet. At the bottom of
the new sheet, it calculates the average for the upper and lower bounds.
These averages are essentially based on 6x1,000 runs. A real Monte Carlo
simulation would need more iterations, of course.
Setting the CutCopyMode fo False is usually wise after a copy
operation—otherwise the copied area remains highlighted.
What you need to do
Sub Profit()
Dim oData As Worksheet, oWS As Worksheet,
oRange As Range, i As Integer
Sheet1.Activate
Set oData = ActiveSheet
Set oWS = Worksheets.Add(, Sheets(Sheets.Count))
For i = 1 To 30 Step 5
oData.Calculate
Set oRange = oData.Range("A13:J16")
oRange.Copy
oWS.Cells(i, 1).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Range("B31:G31").Formula =
"=AVERAGE(B3,B8,B13,B18,B23,B28)"
Range("B32:G32").Formula =
"=AVERAGE(B4,B9,B14,B19,B24,B29)"
oWS.Cells.NumberFormat = "$#,##0.00":
oWS.Columns(1).NumberFormat = "0"
oWS.Cells.EntireColumn.AutoFit
oWS.Cells(1, 1).Activate
End Sub
Chapter 38: Uncertainty in Sales
What the simulation does
Option Explicit
Sub SalesSimulation()
Dim oRange As Range, oTable As Range, i As
Long, n As Long, sMsg As String
Set oRange = Range("F4").CurrentRegion
With oRange
Set oTable = .Offset(2, 0).Resize(.Rows.Count -
2, .Columns.Count)
End With
oTable.ClearContents
n = InputBox("How many runs (1,000 to
100,000)?", , 10000)
Set oTable = Range(Cells(3, 6), Cells(n, 9))
'oTable.Offset(0, 0).Resize(n, Columns.Count)
oTable.Columns(1).Formula =
"=VLOOKUP(RAND(),$C$3:$D$5,2)"
oTable.Columns(2).Formula =
"=VLOOKUP(RAND(),$C$10:$D$13,2)"
oTable.Columns(3).Formula =
"=VLOOKUP(RAND(),$C$18:$D$20,2)"
oTable.Columns(4).Formula = "=F3*G3*H3"
Do
Application.Calculate
i=i+1
sMsg = sMsg & "Loop" & i & " (" & n & "
times): average="
sMsg = sMsg & FormatCurrency(Range("Q2"),
0) & vbCr
MsgBox sMsg
Loop Until MsgBox("Run again?", vbYesNo) =
vbNo
End Sub
Chapter 39: Exchange Rate
Fluctuations
What the simulation does
Option Explicit
Sub ExchangeRates()
Dim oRange As Range, iRuns As Long, i As Long,
sMsg As String
Dim arrAvg() As Double, arr25() As Double,
arr75() As Double
Dim pAvg As Double, p25 As Double, p75 As
Double 'for the currencies
Dim sAvg As String, s25 As String, s75 As String
'for the formatted currencies
Range("D1").CurrentRegion.Offset(1,
0).ClearContents
iRuns = InputBox("How many runs?", , 1000)
Range("E2").Formula = "=B5"
Range("F2").Formula = "=B14"
Set oRange = Range(Range("D2"),
Range("F2").Cells(iRuns, 1))
oRange.Table , Range("B5")
sMsg = "Runs" & vbTab & "25%" & vbTab &
vbTab & "Average" & vbTab & vbTab & "75%" &
vbCr
Do
oRange.Columns(1).Formula =
"=NORMINV(RAND(),$B$5,$B$6)"
oRange.Columns(1).Formula =
oRange.Columns(1).Value
ReDim Preserve arrAvg(i): ReDim Preserve
arr25(i): ReDim Preserve arr75(i)
arrAvg(i) =
WorksheetFunction.Average(oRange.Columns(3))
arr25(i) =
WorksheetFunction.Percentile(oRange.Columns(3),
0.25)
arr75(i) =
WorksheetFunction.Percentile(oRange.Columns(3),
0.75)
sAvg = FormatCurrency(arrAvg(i), 0)
s25 = FormatCurrency(arr25(i), 0)
s75 = FormatCurrency(arr75(i), 0)
sMsg = sMsg & i + 1 & vbTab & s25 & vbTab &
sAvg & vbTab & s75 & vbCr
i=i+1
Loop Until MsgBox(sMsg & "Run again?",
vbYesNo) = vbNo
pAvg = WorksheetFunction.Average(arrAvg): sAvg
= FormatCurrency(pAvg, 0)
p25 = WorksheetFunction.Percentile(arr25, 0.25):
s25 = FormatCurrency(p25, 0)
p75 = WorksheetFunction.Percentile(arr75, 0.75):
s75 = FormatCurrency(p75, 0)
sMsg = sMsg & vbCr & "mean:" & vbTab & s25 &
vbTab & sAvg & vbTab & s75
MsgBox sMsg
End Sub
IV. GENETICS
Chapter 40: Shuffling Chromosomes
What the simulation does
Option Explicit
Sub Chromosomes()
Dim pArr() As Double, i As Long, n As Long, sMsg
As String
Dim pAvg As Double, pMin As Double, pMax As
Double, pCount As Long
sMsg = sMsg & "run" & vbTab & "min" & vbTab
& "avg" & vbTab & "max" & vbCr
Do
For i = 0 To 100000
ReDim Preserve pArr(i)
pArr(i) = WorksheetFunction.Binom_Inv(23,
0.5, Rnd)
Next i
n=n+1
pAvg =
FormatNumber(WorksheetFunction.Average(pArr),
2)
pMin = WorksheetFunction.Min(pArr)
pMax = WorksheetFunction.Max(pArr)
pCount = UBound(pArr)
sMsg = sMsg & n & vbTab & pMin & vbTab &
pAvg & vbTab & pMax & vbCr
Loop Until MsgBox(sMsg, vbOKCancel) =
vbCancel
End Sub
Chapter 41: Sex Determination
What the simulation does
This sheet simulates what happens when a father (XY) and a mother
(XX) have one descendant, who has in turn another descendant, and so forth.
It is something like a family tree.
If the descendant is a female (XX), that cell gets marked with a color.
If the descendant still has the original Y-chromosome (Y*) from the (great-
great-grand-) father, that chromosome is marked with an asterix (*). In the
figure above, there happen to be seven female descendants, and the ancestral
Y-chromosome got already “lost” by mere chance in the first generation.
The macro asks the user first how many generations they want to
simulate (the maximum is set to 10). The macro keeps asking that question
by calling itself again, and it does so until the user hits the Cancel button of
the Inputbox. It is possible, by mere change, that the paternal X-chromosome
persists for six generations (see picture below)—or even longer.
What you need to know
One of the 23 pairs of chromosomes is called the sex-chromosome
pai r. It either holds two similar chromosomes (XX) or two unalike
chromosomes (XY; Y is actually a very short chromosome). The presence of
the Y-chromosome determines maleness.
The father (XY) produces sperm cells with either an X-chromosome
(50% chance) or a Y-chromosome (50% chance). If the egg cell—which has
always one X-chromosome—is fertilized by a sperm cell with a Y-
chromosome, the descendant will be a male. So there is a 50% chance for
either a male or a female descendant (in reality, there is a slight difference in
chance, though).
What you need to do
Option Explicit
Sub Sex()
Dim r As Integer, c As Integer, sGens As String,
oCell As Range
sGens = InputBox("How many generations
(<=10)?", , 10, 10000, 2000)
If sGens = "" Then Exit Sub
If CInt(sGens) > 10 Then MsgBox "Not more than
10": Exit Sub
For Each oCell In Range("D3:O22")
If oCell = "XX" Or oCell = "XY" Or oCell =
"XY*" Then
oCell.ClearContents:
oCell.Interior.ColorIndex = 0
End If
Next oCell
c=3
For r = 3 To (2 * CInt(sGens) + 1) Step 2
c=c+1
Cells(r, c) = IIf(Rnd > 0.5, "XX", IIf(Cells(r - 2,
c - 1) = "XY*", "XY*", "XY"))
Cells(r, c + 2) = IIf(Cells(r, c) = "XX", "XY",
"XX")
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Chapter 42: Mendelian Laws
What the simulation does
Option Explicit
Sub Mendel()
Dim arrDom() As Variant, arrRec() As Variant,
arrX() As Variant '3 arrays
Dim iDom As Long, iRec As Long, iX As Long, i
As Long, n As Long, sMsg As String
sMsg = "run" & vbTab & "Aa dom." & vbTab &
"aa rec." & vbTab & "X rec." & vbCr
Again:
n=n+1
sMsg = sMsg & n & vbTab
For i = 0 To 10000
ReDim Preserve arrDom(i)
arrDom(i) = IIf(Rnd < 0.5, "'Aa", "aa")
If arrDom(i) = "'Aa" Then iDom = iDom + 1
Next i
sMsg = sMsg & FormatPercent(iDom / 10000, 2) &
vbTab
For i = 0 To 10000
ReDim Preserve arrRec(i)
arrRec(i) = IIf(Rnd < 0.5, "'AA", IIf(Rnd < 0.5,
"Aa", "'aa"))
If arrRec(i) = "'aa" Then iRec = iRec + 1
Next i
sMsg = sMsg & FormatPercent(iRec / 10000, 2) &
vbTab
For i = 0 To 10000
ReDim Preserve arrX(i)
arrX(i) = IIf(Rnd < 0.25, "HH", IIf(Rnd < 0.33,
"H'h", IIf(Rnd < 0.5, "H-", "'h-")))
If arrX(i) = "'h-" Then iX = iX + 1
Next i
sMsg = sMsg & FormatPercent(iX / 10000, 2) &
vbCr
A gene can carry various alleles. Let us assume there are only two
alleles, A and a. People who have two of the same alleles are homozygotes
(AA or aa). Those who carry both alleles are heterozygotes (Aa). Let us take
the example of an allele for albinism (a), which is recessive, so albinos
must be aa, whereas individuals with the genotypes AA and Aa are not
albinos. If we know the percentage (q2) of albinos (aa), we can calculate the
frequency q of allele a, as well as the frequency p of allele A—provided
there are no other alleles—since p=1-q.
As a consequence, the frequency would be p2 for the homozygotes AA
(cell D4), q2 for the homozygotes aa (cell D2), and 2pq for the heterozygotes
(in cell D3: pq for Aa and qp for aA). So if we know that aa has a frequency
of 10%, we can deduce what the frequencies are for Aa and AA (see the
comments in those cells shown in the figure above).
What you need to know
The Hardy-Weinberg law states that if
these genotypes would randomly mate, the frequencies would stay the same
in the next generations. We are going to simulate this with a macro. We
know, based on Mendelian laws, what the offspring would be of certain
pairs of parents (see H1:L10). The macro is going to randomly make these
combinations and randomly determine what their offspring would be. The
result, based on 10,000 runs, is displayed in a MsgBox. Notice how the
frequencies in the next generation are extremely close to the frequencies of
the parent generation—which is exactly what the Hardy-Weinberg law
states.
The VLOOKUP function plays an important role in this simulation. It
finds randomly the genotype of each parent and then finds randomly (with a
random number between 2 and 5) the child’s genotype in one of the 2nd to 5th
columns of range H:L.
If we change the frequency of aa to 40%, the next generation will
more or less keep that frequency because of random mating. Obviously, the
total of the frequencies should be 100%
What you need to do
Option Explicit
Sub HardyWeinberg()
Dim arrMales() As String, arrFemales() As String,
arrChildren() As String
Dim iHomDom As Long, iHetero As Long,
iHomRec As Long
Dim i As Long, pRec As Double, iRnd As Integer,
sMsg As String, iCount As Long
pRec = InputBox("Frequency of aa", , 0.1)
Range("D2") = pRec
ReDim arrMales(0 To 10000)
ReDim arrFemales(0 To 10000)
ReDim arrChildren(0 To 10000)
For i = 0 To 10000
arrMales(i) =
WorksheetFunction.VLookup(Rnd, Range("B2:C4"),
2, 1)
arrFemales(i) =
WorksheetFunction.VLookup(Rnd, Range("B2:C4"),
2, 1)
iRnd = WorksheetFunction.RandBetween(2, 5)
arrChildren(i) =
WorksheetFunction.VLookup(arrMales(i) &
arrFemales(i), Range("H2:L10"), iRnd, False)
If arrChildren(i) = "A'A'" Then iHomDom =
iHomDom + 1
If arrChildren(i) = "A'a" Then iHetero = iHetero
+1
If arrChildren(i) = "aa" Then iHomRec =
iHomRec + 1
Next i
iCount = UBound(arrChildren)
sMsg = "After " & iCount & " generations:" &
vbCr
sMsg = sMsg & "aa: " & FormatPercent(iHomRec
/ iCount, 1) & vbCr
sMsg = sMsg & "A'a: " & FormatPercent(iHetero /
iCount, 1) & vbCr
sMsg = sMsg & "A'A': " &
FormatPercent(iHomDom / iCount, 1)
MsgBox sMsg
End Sub
Chapter 44: Genetic Drift
What the simulation does
Option Explicit
Sub Drifting()
Dim pDrift As Double, i As Long, oRange As
Range, oChart As Chart, oShape As Shape
On Error GoTo ErrTrap
pDrift = InputBox("Drift factor", , 0.02)
Set oRange = Range("A8:A108")
oRange.Formula = "=ROW(A1)-1"
Range("B7") = "AA"
Range("B8").Formula = "=C3"
Range("C7") = "Aa"
Range("C8").Formula = "=C4+D3"
Range("D7") = "aa"
Range("D8").Formula = "=D4"
Set oRange = Range("B9:B108")
oRange.Formula = "=NORMINV(RAND(),B8," &
pDrift & ")"
Set oRange = Range("C9", "C108")
oRange.Formula = "=IFERROR(2*SQRT(B9)*(1-
SQRT(B9)),NA())"
Set oRange = Range("D9:D108")
oRange.Formula = "=IFERROR((1-
SQRT(B9))^2,NA())"
Set oRange = Range("B7").CurrentRegion
Set oChart = Charts.Add
oChart.SetSourceData oRange
oChart.ChartType = xlXYScatterLinesNoMarkers
Sheets(1).Select
ActiveChart.ChartArea.Copy
Sheets(2).Select
ActiveSheet.PasteSpecial Format:="Picture
(JPEG)"
Selection.ShapeRange.ScaleWidth 0.8, msoFalse
Selection.ShapeRange.ScaleHeight 0.8, msoFalse
Selection.ShapeRange.IncrementLeft 100
Selection.ShapeRange.IncrementTop 100
Application.DisplayAlerts = False
Sheets(1).Delete
oRange.Clear
Application.DisplayAlerts = True
Exit Sub
ErrTrap:
Err.Clear
End Sub
Chapter 45: Two Selective Forces
What the simulation does
Option Explicit
Sub Selecting()
Dim i As Integer, n As Integer, oRange As Range, j
As Integer
Set oRange = Range("D4:F27")
For i = 1 To 24
If i Mod 4 <> 1 Then oRange.Range(Cells(i, 1),
Cells(i, 4)).ClearContents
Next i
MsgBox "This starts looping through 6 settings for
t and s."
For i = 4 To 24 Step 4
Range("E1") = Cells(i, 2)
Range("E2") = Cells(i, 3)
For n = 1 To 3
Set oRange = Range(Cells(i + n, 4), Cells(i +
n, 6))
oRange.FormulaArray = "=INDEX(L2:N34,"
& Cells(i + n, 1) & ",0)"
oRange.NumberFormat = "0.00%"
oRange.Formula = oRange.Value
Next n
If MsgBox("Factor t is " & Range("E1") & "
factor s is " & _
Range("E2"), vbOKCancel) = vbCancel
Then Exit Sub
Next i
End Sub
Chapter 46: Differential Fitness
What the simulation does
Option Explicit
Sub Fitness()
Dim arrParents() As String, arrChild() As String, i
As Long, sMsg As String
Dim pFreqAA As Double, pFreqAS As Double,
pFreqSS As Double
Dim pAA As Double, pAS As Double, pSS As
Double, iCount As Long, iBlank As Long
pFreqSS = Range("D2")
pFreqAA = Range("D3")
pFreqAS = Range("D4")
sMsg = "Frequencies for" & vbTab & "SS" &
vbTab & "AA" & vbTab & "AS" & vbCr
sMsg = sMsg & "1st generation: " & vbTab &
FormatPercent(pFreqSS, 0) & vbTab &
FormatPercent(pFreqAA, 0) & vbTab &
FormatPercent(pFreqAS, 0) & vbCr
Range("P2:S10") = ""
Range("P2:S10").Formula = "=IF(RAND()
<VLOOKUP(G2,$L$2:$M$4,2,0),G2,"""")"
For i = 0 To 10000
ReDim Preserve arrParents(i)
ReDim Preserve arrChild(i)
Free ebooks ==> www.Ebook777.com
arrParents(i) =
WorksheetFunction.VLookup(Rnd, Range("B2:C4"),
2, 1) & WorksheetFunction.VLookup(Rnd,
Range("B2:C4"), 2, 1)
arrChild(i) =
IIf(WorksheetFunction.RandBetween(0, 6) > 1,
WorksheetFunction.VLookup(arrParents(i),
Range("O2:S10"),
WorksheetFunction.RandBetween(2, 5), False), "")
If arrChild(i) = "AA" Then pAA = pAA + 1
If arrChild(i) = "AS" Then pAS = pAS + 1
If arrChild(i) = "SS" Then pSS = pSS + 1
If arrChild(i) = "" Then iBlank = iBlank + 1
Next i
iCount = UBound(arrChild) - iBlank
sMsg = sMsg & "2nd generation: " & vbTab &
FormatPercent(pSS / iCount, 0) & vbTab &
FormatPercent(pAA / iCount, 0) & vbTab &
FormatPercent(pAS / iCount, 0) & vbCr
'For more generations, Range("D2") needs to be
reset to (pSS/iCount)
MsgBox sMsg
End Sub
www.Ebook777.com
Chapter 47: Molecular Clock
What the simulation does
Option Explicit
Sub Ancestry()
Dim pTarget As Double, sTarget As String, pPerc
As Double, iStepYrs As Long
Dim iUnchanged As Long, iYrs As Double, iRate
As Double, sMsg As String
sTarget = InputBox("Percentage of DNA
difference?", , "10%")
If Right(sTarget, 1) <> "%" Then sTarget = sTarget
& "%"
pTarget = Left(sTarget, Len(sTarget) - 1) / 100
Range("F5") = sTarget 'OR:
FormatPercent(pTarget, 2)
iStepYrs = Range("C5")
iUnchanged = Range("C4") * 10000000
sMsg = "For " & sTarget & " we found:" & vbCr
For iYrs = iStepYrs To (iStepYrs + 10 * iStepYrs)
Step iStepYrs
For iRate = (iUnchanged - 8) To iUnchanged
pPerc = 2 * (1 - (iRate / 10000000) ^ iYrs)
If pPerc < (pTarget + 0.005) And pPerc >
(pTarget - 0.005) Then
sMsg = sMsg & "Years ago: " & iYrs &
vbTab & "at rate: " & iRate / 10000000 & vbCr
End If
Next iRate
Next iYrs
If Len(sMsg) < 25 Then sMsg = sMsg & "No
results"
MsgBox sMsg
End Sub
Chapter 48: DNA Sequencing
What the simulation does
Option Explicit
Sub Sequencing()
Dim pNoLabel As Double, i As Integer, j As
Integer, sMsg As String
Dim arrDNA() As String, arrStrand() As String,
sNucl As String, bFound As Boolean
pNoLabel = InputBox("Choose % unlabeled
between 0.85 and 0.95", , 0.9)
If pNoLabel > 0.95 Then Exit Sub
Range("B1") = pNoLabel
sMsg = "With " & FormatPercent(1 - pNoLabel, 0)
& " labeled nucleotides:" & vbCr
ReDim arrDNA(0 To 10)
For i = 0 To 10
arrDNA(i) =
WorksheetFunction.VLookup(WorksheetFunction.RandBetwee
4), Range("A2:B5"), 2, 0)
sMsg = sMsg & arrDNA(i) & vbTab
ReDim arrStrand(0 To 39)
For j = 0 To 39
arrStrand(j) = IIf(Rnd > Range("B1"),
Left(WorksheetFunction.VLookup(arrDNA(i),
Range("B2:C5"), 2, 0), 1), " ")
If arrStrand(j) <> " " Then sNucl =
arrStrand(j): bFound = True
Next j
sMsg = sMsg & Join(arrStrand) & vbTab
sMsg = sMsg & IIf(bFound, sNucl, "-") & "->"
& arrDNA(i) & vbCr
sNucl = "": bFound = False
Next i
MsgBox sMsg
End Sub
V. SCIENCE
Chapter 49: Matrix Elimination
What the simulation does
=C14*$C$18+D14*$D$18+E14*$E$18+F14*$F$18.
www.Ebook777.com
What you need to do
Option Explicit
Sub MatrixElimination()
Dim oMatrixA As Range, oMatrixY As Range,
oResults As Range, sMsg As String, i As Integer
On Error GoTo ErrTrap 'Set
Tools|Options|General: Break on unhandled errors
Set oMatrixA = Application.InputBox("Select
range of A-coefficients", ,
Range("C14:F17").Address, , , , , 8)
Set oMatrixY = Application.InputBox("Select
corresponding range of Y's", ,
Range("H14:H17").Address, , , , , 8)
Set oResults =
oMatrixA.Rows(oMatrixA.Rows.Count + 1)
oResults.FormulaArray =
"=TRANSPOSE(MMULT(MINVERSE(" &
oMatrixA.Address & ")," & _
oMatrixY.Address &
"))"
sMsg = "Results for X-values:" & vbCr
For i = 1 To oResults.Cells.Count
sMsg = sMsg & "X" & i & ":" & vbTab &
oResults.Cells(1, i) & vbCr
Next i
MsgBox sMsg
Exit Sub
ErrTrap:
MsgBox "There was an error: " & Err.Description
Err.Number = 0
End Sub
Chapter 50: Integration with
Simulation
What the simulation does
Option Explicit
Sub Integration()
Dim i As Long, n As Long, pX() As Double, pY()
As Double, pInOut() As Integer
Dim iCount As Long, iSimulArea As Long, sMsg
As String, iLoops As Integer
n = InputBox("How many runs?", , 10000)
Do
For i = 0 To n - 1
ReDim Preserve pX(i)
pX(i) = Rnd * 10 '=RAND()*10
ReDim Preserve pY(i)
pY(i) = Rnd * 200
ReDim Preserve pInOut(i)
pInOut(i) = IIf(pY(i) > -pX(i) ^ 3 + 10 * pX(i)
^ 2 + 5 * pX(i), 0, 1)
Next i
Range("F2") = n
iCount = WorksheetFunction.Sum(pInOut)
Range("F3") = iCount
iSimulArea = 2000 * iCount / n
Range("F4") = iSimulArea
MsgBox "Throws: " & n & vbCr & "in circle: "
& iCount & vbCr & "simul.area: " & iSimulArea
iLoops = iLoops + 1
sMsg = sMsg & "Loop " & iLoops & " area: " &
vbTab & iSimulArea & vbCr
Loop Until MsgBox(sMsg & vbCr & "Keep
looping?", vbYesNo) = vbNo
End Sub
Chapter 51: Two Monte Carlo
Integrations
What the simulation does
This time, we discuss only two equations as an example: Y=X (on the
1st sheet) and Y=X^2 (on the 2nd sheet), and we do so without using any
integration formula.
What you need to know
VBA generates two arrays of random X-values and random Y-values.
They are plotted in the left graph.Then another set of two arrays, according
to the formulas shown in VBA. Those two are plotted in the right graph. In a
5th array, we assign 1 ’s when the two previous columns have X- and Y-
values in it, so we can calculate the area under the curve. All of this is done
100,000 times.
What you need to do
Sub Integration()
Dim pXmin As Double, pXmax As Double, pYmin
As Double, pYmax As Double
Dim oWS As Worksheet, pX() As Double, pY() As
Double, i As Long, iCount As Long
Dim pXif() As Double, pYif() As Double, pInOut()
As Double, pSum As Double
If MsgBox("Do you want to be on Sheet1?",
vbYesNo) = vbYes Then
Sheet1.Select
Else
Sheet2.Select
End If
iCount = InputBox("How many runs?", , 100000)
Set oWS = ActiveSheet
pXmin = Range("B4"): pXmax = Range("C4")
pYmin = Range("B5"): pYmax = Range("C5")
For i = 0 To (iCount - 1)
ReDim Preserve pX(i)
pX(i) = pXmin + (pXmax - pXmin) * Rnd
ReDim Preserve pY(i)
pY(i) = pYmin + (pYmax - pYmin) * Rnd
ReDim Preserve pXif(i)
If oWS.Name = Sheet1.Name Then
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Chapter 52: Monte Carlo Approach
of Pi
What the simulation does
Option Explicit
Sub PiSimulation()
Dim i As Integer
MsgBox "Be patient until the next MsgBox
appears"
Cells.EntireColumn.AutoFit
Cells.EntireColumn.NumberFormat = "0.00000"
Range("A1").Formula = "=Pi()"
For i = 1 To 6 Step 2
Range(Cells(5, i), Cells(1004, i)).Formula =
"=PiEstimate(10000)"
Cells(3, i) =
WorksheetFunction.Average(Cells(5, i), Cells(1004,
i))
Next i
Range("E1").Formula = "=AVERAGE(A5:E1004)"
MsgBox "Mean of 3x1,000 runs is " &
FormatNumber(Range("E1"), 5)
End Sub
Chapter 53: A Population Pyramid
What the simulation does
This simulation shows how a population pyramid may change over the
course of 100 years. The simulation is based on several grossly
oversimplified assumptions.
Assumption #1: The population starts at 100,000 (cell D11).
Assumption #2: The birth rate is partially randomized (row 12) and is
based on participation by everyone over 20 years old.
Assumption #3: Every age group has a certain survival value (column
B) which is subject to small fluctuations, determined by a randomize factor
(InputBox, by default 2%).
With three InputBoxes you can determine your randomize factor (by
default 0.02), the minimum birth rate (by default 0.1), and the maximum birth
rate (by default 0.4). Then the macro loops through 100 years in steps of 10
and shows the situation after that number of years.
What you need to know
The cells B16:B25 use the function HLOOKUP, which searches for a
value in the top row of a table or an array of values, and then returns a value
in the same column from a row you specify in the table or array. It has the
following syntax: HLOOKUP(value, table or array, row index number, exact
match or not). So the formula in B16 is:
=HLOOKUP([Years],$D$1:$N$11,ROW(A2),0)., where ROW(A2), copied
down, becomes ROW(A3), etc. So it finds the number of years horizontally
in the first row of D1:N11, and then returns the 2nd cell down, 3rd cell, etc.
For 100 years, B16:B25 should be the same as N2:N11.
The cells C16:C25 calculate how far each bar in the chart should be
offset to the right, which is done with the formula: =(MAX($B$16:$B$25)-
B16)/2.
The chart is a stacked bar chart, and plots A2:A11 against B6:B25 and
C6:C25.
What you need to do
Option Explicit
Sub Pyramid()
Dim iYears As Integer, pSurvivalFluct As Double,
pMinRate As Double, pMaxRate As Double
MsgBox "You can manually change survival rates
in the cells B2:B11"
pSurvivalFluct = InputBox("What is the
randomize factor?", , 0.02)
pMinRate = InputBox("Minimum birthrate", ,
0.1)
pMaxRate = InputBox("Maximum birthrate", ,
0.4)
'iYears = InputBox("The situation after how many
years?", , 100)
Do
Range("C2:C11").Formula =
"=NORMINV(RAND(),B2," & pSurvivalFluct & ")"
Range("C2:C11").Formula =
Range("C2:C11").Value
Range("D12:N12").Formula =
"=RANDBETWEEN(" & (pMinRate * 100) & "," &
(pMaxRate * 100) & ")/100"
Range("D12:N12").Formula =
Range("D12:N12").Value
For iYears = 10 To 100 Step 10
Range("B15") = iYears
Range("B16:B25").Formula =
"=HLOOKUP(" & iYears &
",$D$1:$N$11,ROW(A2),0)"
MsgBox "After " & iYears & " years."
Next iYears
Range("B16:B25").Formula =
Range("B16:B25").Value
Loop Until MsgBox("Another run?", vbYesNo) =
vbNo
End Sub
Chapter 54: Predator-Prey Cycle
What the simulation does
www.Ebook777.com
What you need to do
Sub LotkaVolterra()
Do
Range("A2") =
Cells(WorksheetFunction.RandBetween(2, 4), 9)
Range("B2") =
Cells(WorksheetFunction.RandBetween(2, 4), 10)
Range("C2") =
Cells(WorksheetFunction.RandBetween(2, 4), 11)
CreateCharts 'see Sub below
Loop Until MsgBox("Loop again?", vbYesNo) =
vbNo
End Sub
Sub CreateCharts()
Dim oRange As Range, i As Integer, oChart As
Chart, sCaption As String
Dim oWS As Worksheet, bWS As Boolean, oAS As
Worksheet
Set oAS = ActiveSheet
For Each oWS In Worksheets
If oWS.Name = "Chart" Then bWS = True
Next oWS
If bWS = False Then
Set oWS = Worksheets.Add(, ActiveSheet):
oWS.Name = "Chart"
Else
Set oWS = Worksheets("Chart")
End If
oAS.Select
Set oRange = Range("B5").CurrentRegion
Set oChart = Charts.Add
With oChart
.SetSourceData oRange:
.ChartArea.Border.Weight = xlThick
.ChartType = xlXYScatterSmoothNoMarkers
.HasTitle = True:
.Axes(xlCategory).MaximumScale = 500
.FullSeriesCollection(1).XValues =
.FullSeriesCollection(1).XValues
.FullSeriesCollection(2).Values =
.FullSeriesCollection(2).Values
sCaption = oAS.Range("A2") & "|" &
oAS.Range("B2") & "|" & oAS.Range("C2")
.ChartTitle.Caption = sCaption: .Location
xlLocationAsObject, oWS.Name
End With
oWS.Activate
For i = 1 To oWS.ChartObjects.Count
With oWS.ChartObjects(i)
.Width = ActiveWindow.Width * 0.4:
.Height = ActiveWindow.Height * 0.6
.Left = ((i - 1) Mod oWS.ChartObjects.Count)
* ActiveWindow.Width * 0.41
.Top = Int((i - 1) / oWS.ChartObjects.Count) *
150
End With
Next i
MsgBox "Here is the Chart": oAS.Activate
End Sub
Chapter 55: Taking Medication
What the simulation does
Option Explicit
Sub Medication()
Dim n As Integer, i As Integer, pTime As Double,
sStr As String
Dim pDosage As Double, pElim As Double, pUnit
As Double, pInterv As Double
pDosage = Range("B3"): pElim =
Range("B4"): pUnit = Range("B6"): pInterv =
Range("B7")
For n = 1 To 5 'for number of pills
Range("B1") = n
Range(Cells(11, 1), Cells(211, 3)).ClearContents
For i = 11 To 211
Cells(i, 1) = Cells(i - 1, 1) + pInterv
sStr = "INT(R1C2*RC[-1])/R1C2"
Cells(i, 2).FormulaR1C1 =
"=IF(AND(RC[-1]>" & sStr & ",RC[-1]<" & sStr &
"+R6C2),8,0)"
Cells(i, 2).Formula = Cells(i, 2).Value
Cells(i, 3) = Cells(i - 1, 3) + pInterv *
(pDosage * Cells(i, 2) - pElim * Cells(i - 1, 3))
pTime = Timer + 0.005
Do While Timer < pTime
DoEvents
Loop
Next i
sStr = "This is for " & n & " pills per day."
If n < 5 Then
If MsgBox(sStr & vbCr & "Continue?",
vbYesNo) = vbNo Then Exit Sub
Else
MsgBox sStr
End If
Next n
End Sub
Chapter 56: The Course of an
Epidemic
What the simulation does
Option Explicit
Sub Epidemic()
Dim sMsg As String, pTime As Double, i As Long
Range("A3:E302").ClearContents
'If MsgBox("Are the values in column H as you
want them?", vbYesNo) = vbNo Then Exit Sub
For i = 3 To 302
Cells(i, 1).FormulaR1C1 = "=R[-1]C+R1C8"
'A2+$H$1"
Cells(i, 2).FormulaR1C1 = "=R[-1]C-
(R6C8*R[-1]C*R[-1]C[1])*R1C8"
Cells(i, 3).FormulaR1C1 = "=R[-1]C+
(R6C8*R[-1]C[-1]*R[-1]C-R7C8*R[-1]C)*R1C8"
Cells(i, 4).FormulaR1C1 = "=R[-1]C+((1-
R8C8)*R7C8*R[-1]C[-1])*R1C8"
Cells(i, 5).FormulaR1C1 = "=R[-1]C+
(R8C8*R7C8*R[-1]C[-2])*R1C8"
Range("N1") = "done " & FormatPercent(i /
302, 0)
Range("J8") = WorksheetFunction.Rept(">", i /
302 * 100)
If i / 302 <= 0.25 Then
If i Mod 5 = 0 Then
pTime = Timer
Do While Timer < pTime + 1.5
DoEvents
Loop
End If
End If
Next i
sMsg = "Total recovered: " &
FormatNumber(Range("D302"), 0) & vbCr
sMsg = sMsg & "Total deaths: " &
FormatNumber(Range("E302"), 0) & vbCr
sMsg = sMsg & "Total never sick: " &
FormatNumber(Range("B302"), 0) & vbCr
sMsg = sMsg & "Max sick at once: " &
FormatNumber(WorksheetFunction.Max(Columns(3)),
0)
MsgBox sMsg
If MsgBox("Do you want to keep the formulas on
the sheet?", vbYesNo) = vbNo Then
Range("A3:E302").Formula =
Range("A3:E302").Value
End If
End Sub
Chapter 57: Boltzmann Equation for
Sigmoidal Curves
What the simulation does
This simulation deals with curves that are of the logistic, s-shaped, or
sigmoidal type, so we could use the Boltzmann equation as explained in the
figure above (where E is the independent variable in column A, and V the
half-way activity). The values in columns C:E and H are all calculated (see
figure on the next page), except for the values in H1 and H2, which are
based on an educated guess.
Something similar can be done for EC50 or IC50 determination.The
term “half maximal effective concentraion” (EC50) refers to the
concentration of a drug, antibody, or toxicant which induces a response
halfway between the baseline and maximum after a specified exposure time.
It is commonly used as a measure of a drug’s effective potency. (IC50, on the
other hand, is the “half maximal inhibitory response.”)
The columns D and E calculate the confidence interval on both sides
of the curve of observed values based on cell H8 (see Chapter 18).
What you need to know
In order to get a more accurate value for the half-way value and the
slope, we need to set the Sum of Squared Residuals (H6) to a minimum,
which means that the difference between what we observed and what we
expected according to the equation is minimal.
We can do so by using Excel’s Solver tool. Make sure Solver is active
in VBA: Tools | References | Solver ON. Now the macro can call Solver.
On the screen shot to the left, cell H6 is set to a minimum by changing the
variable cells H1:H2 (the educated guesses). Since there can be several
solutions to this problem, it is wise to add some constraints—for instance,
that H1 should be between -5 and -15.
What you need to do
Option Explicit
Sub Boltzman()
Dim pHalfX As Double, pSlope As Double
Range("C2:E20").ClearContents:
Range("H1:H8").ClearContents
pHalfX = InputBox("Guess half-X-value for half-Y
at 0.5", , -10)
pSlope = InputBox("Guess what the slope would
be", , 10)
Range("H1").Formula = pHalfX:
Range("H2").Formula = pSlope
Range("H3").Formula = "=AVERAGE(B:B)"
'mean Y
Range("H4").Formula = "=COUNT(B:B)-
COUNT(H1:H2)" 'degrees of freedom
Range("H5").FormulaArray =
"=SQRT(SUM((B2:B20-C2:C20)^2)/H4)" 'Standard
Error Y
Range("H6").FormulaArray = "=SUM((B2:B20-
C2:C20)^2)" 'Sum Squared Residuals
Range("H7").Formula = "=TINV(0.05,H4)"
'Critical t-value
Range("H8").Formula = "=H7*H5" 'Confidence
Interval
Range("C2:C20").Formula = "=(1/(1+EXP(($H$1-
A2)/$H$2)))"
Range("D2:D20").Formula = "=C2+$H$8"
Range("E2:E20").Formula = "=C2-$H$8"
'Tools | References | Solver ON
SolverOkDialog "H6", 2, 0, "H1:H2", 1, "GRG
Nonlinear"
End Sub
Chapter 58: Interpolation
What the simulation does
WorksheetFunction.Min(oRange.Columns(1)):
Range("E5") = vMinX
Range("E6") = Range("E1"): Range("E7") =
Range("E1")
vTrend =
WorksheetFunction.Trend(Range("F2:F3"),
Range("E2:E3"), Range("E1"))
Range("F5") = vTrend: Range("F6") = vTrend
vMinY =
WorksheetFunction.Min(oRange.Columns(2)):
Range("F7") = vMinY
If MsgBox("A separate graph?", vbYesNo) = vbYes
Then Charting
End Sub
Sub Charting()
Dim r As Long, pMin1 As Double, pMin2 As
Double, sX As String, sY As String
Dim oChart As Chart, oRange As Range
Set oRange = Range("A1").CurrentRegion: r=
oRange.Rows.Count
sX = Range(Cells(2, 1), Cells(r, 1)).Address: sY =
Range(Cells(2, 2), Cells(r, 2)).Address
Set oRange = Union(Range(sX), Range(sY)): Set
oChart = Charts.Add(, ActiveSheet)
With oChart
.ChartType = xlXYScatterSmooth:
www.Ebook777.com
.SetSourceData oRange
.HasTitle = True: .HasLegend =
True:.Axes(xlCategory).HasMajorGridlines = True
.Axes(xlCategory).HasMinorGridlines = True:
pMin1 =
WorksheetFunction.Min(Columns(1)): pMin2 =
WorksheetFunction.Min(Columns(2))
.Axes(xlValue).MinimumScale = IIf(pMin1 <
pMin2, Int(pMin1), Int(pMin2))
.Axes(xlValue).HasMinorGridlines = True
.ChartTitle.Caption = "Graph based on columns
"&_
vbCr & Cells(1, 1) & " and " & Cells(1,
2) & " for X=" & Range("E1")
.SeriesCollection(1).Name = Cells(1, 1):
.SeriesCollection(2).Name = Cells(1, 2)
End With
With oChart.SeriesCollection.NewSeries
.XValues = Range("E5:E7"): .Values =
Range("F5:F7")
.Name = "insert": .ChartType =
xlXYScatterLines
.HasDataLabels = True: .DataLabels.Select
Selection.ShowCategoryName = True:
Selection.ShowValue = True
End With
oChart.SizeWithWindow = True
End Sub
Chapter 59: A Rigid Pendulum
What the simulation does
Option Explicit
Sub Sinusoid()
Dim i As Integer, j As Integer, pTime As Double
Range("J27") = "no": Range("J27").Select
For i = 1 To 7
Sheet2.Range("C6") = i
For j = 0 To 360
Sheet2.Range("E1") = j
pTime = Timer + 0.005 'Timer: secs since
midnight; pause by .005 seconds
Do While Timer < pTime
DoEvents
Calculate
If Range("J27") = "yes" Then Exit Sub
Loop
Next j
Next i
End Sub
Free ebooks ==> www.Ebook777.com
www.Ebook777.com
Chapter 61: The Brusselator Model
What the simulation does
Option Explicit
Sub Oscillation()
Dim i As Integer, j As Integer, pTime As Double
Range("D2") = "no": Range("D2").Select
For i = 35 To 100
Range("D3") = i
For j = 100 To 240
Range("D4") = j
pTime = Timer + 0.005 'Timer: secs since
midnight; pause by .005 seconds
Do While Timer < pTime
DoEvents
Calculate
If Range("D2") = "yes" Then Exit Sub
Loop
Next j
Next i
End Sub
Chapter 62: A Hawk-Dove Game
What the simulation does
Option Explicit
Sub HawkDove()
Dim iGain As Integer, sMsg As String, iTrick As
String
Range("B2:B10").Formula = "=A2*$F$2+(1-
A2)*$G$2"
Range("C2:C10").Formula = "=A2*$F$3+(1-
A2)*$G$3"
For iGain = 10 To 90 Step 10
Range("J2") = iGain
Sheet1.Calculate
sMsg = "The intersect for gain " & iGain & "
equals: " & _
FormatNumber(Range("B19"), 3)
'to position the MsgBox use an InputBox instead
iTrick = InputBox(sMsg, , "next", 1000, 2500)
If iTrick = "" Then Exit Sub
Next iGain
Range("J2") = 50
End Sub
VI. BUSINESS
Chapter 63: Prognosis of Sales
What the simulation does
Option Explicit
Sub Prognosis()
Dim r As Long, c As Integer, oRange As Range, i
As Long, iTime As Long
Dim pAvg As Double, pSD As Double, arrRuns() As
Double
MsgBox "Prognosis per column based on 10,000
iterations."
With Range("A1").CurrentRegion
.Rows(.Rows.Count + 3).Interior.Color =
vbWhite
r = .Rows.Count
For c = 2 To .Columns.Count
pAvg =
WorksheetFunction.Average(.Columns(c))
pSD =
WorksheetFunction.StDev(.Columns(c))
ReDim arrRuns(0 To 9999)
For i = 0 To 9999
arrRuns(i) =
WorksheetFunction.Norm_Inv(Rnd, pAvg, pSD)
Next i
iTime = Timer + 1
Do Until Timer > iTime
DoEvents
Loop
.Cells(r + 2, c) =
WorksheetFunction.Percentile(arrRuns, 0.25)
.Cells(r + 3, c) =
WorksheetFunction.Average(arrRuns)
.Cells(r + 4, c) =
WorksheetFunction.Percentile(arrRuns, 0.75)
With .Cells(r + 3, c).Interior
If .Color = vbYellow Then .Color = vbWhite
Else .Color = vbYellow
End With
Next c
End With
End Sub
Chapter 64: Cycle Percentiles
What the simulation does
This is a simple macro to show the user during a nice cycle of views
what the best or worst sales were—in which months and on which days.
The macro does so by cycling through percentile views in steps of 10.
It allows the user to specify whether to go up from the 10th to 90th percentile,
or down from the 90th percentile to the 10th percentile. It also calculates the
total amount of sales for each percentile view.
What you need to know
There is nothing really new in this VBA code. Based on a Boolean
variable, set through a MsgBox, the cycle goes either up or down.
For the percentile scores, we used the Excel function PERCENTILE.
This function works in all Excel versions. In version 2010 and later, it can
be replaced with PERCENTILE.EXC or PERCENTILE. INC. The former
function does not include k=1, whereas the latter one does. So the latter one
is equivalent to the older function PERCENTILE.
Depending on the percentile step, certain numbers are “hidden” by
assigning a white font. This is done by adding to the collection of
FormatConditions. To prevent that these pile up, we delete all
FormatConditions in the range of sales figures at the end.
To make everything work properly, the macro also needs to “play”
with ScreenUpdating settings.
What you need to do
Option Explicit
Sub PercentileUpOrDown()
Dim oRange As Range, oFormat As
FormatCondition
Dim bDown As Boolean, i As Integer, iPerc As
Integer, pPerc As Double, sMsg As String
If ActiveSheet.Name <> Sheet1.Name Then Exit
Sub
Set oRange = Range("A1").CurrentRegion
Set oRange = oRange.Offset(1,
1).Resize(oRange.Rows.Count - 1,
oRange.Columns.Count - 1)
If MsgBox("Go Down? (No = Go Up)", vbYesNo) =
vbYes Then bDown = True: iPerc = 100
For i = 1 To 9
Application.ScreenUpdating = False
If bDown Then iPerc = iPerc - 10 Else iPerc =
iPerc + 10
pPerc =
WorksheetFunction.Percentile_Exc(oRange, iPerc /
100)
Set oFormat =
oRange.FormatConditions.Add(xlExpression,
xlFormula, "=B2<" & pPerc) 'not A1
Application.ScreenUpdating = True
oFormat.Font.Color = vbWhite '.Interior.Color
= RGB(0, 0, 0) with max of 255
sMsg = "Above the " & iPerc & "th percentile: "
& FormatCurrency(pPerc) & vbCr & "Next?"
If MsgBox(sMsg, vbOKCancel) = vbCancel
Then i = 9
Application.ScreenUpdating = False
oRange.FormatConditions.Delete
Application.ScreenUpdating = True
Next i
End Sub
Chapter 65: Cost Estimates
What the simulation does
The cells A2:C3 are based on manual input, with the low estimates in
row 2 and the high estimates in row 3.
For each of the columns A, B, and C, we simulate normally distributed
values with a mean between low (row 2) and high (row 3) as well as a
standard deviation of 2 units on either side. On the sheet, we use only 100
repeats up to row 103—which is rather risky. Column D calculates the
monthly costs for each case.
To reduce the risk of estimating costs, the macro repeats these 100
steps some 10,000 times by storing the results for each run in arrays. Arrays
work very swiftly and make our estimates less subject to random
fluctuations.
At the end of the macro, a MsgBox displays the 5th and 95th percentile
for these 1,000,000 projections. A new run of the macro will yield different
results, but they differ only slightly.
What you need to know
What you need to do
Option Explicit
Sub Costs()
Dim i As Long, d5Perc As Double, d95Perc As
Double, sMsg As String
Dim arr5Perc() As Double, arr95Perc() As Double
With Range("A4:D103")
.ClearContents
MsgBox "First normally distributed random
calculations:"
Application.Calculation = xlCalculationManual
.Columns(1).Formula =
"=NORMINV(RAND(),SUM(A$2:A$3)/2,
(MAX(A$2:A$3)-MIN(A$2:A$3))/4)"
.Columns(2).Formula =
"=NORMINV(RAND(),SUM(B$2:B$3)/2,
(MAX(B$2:B$3)-MIN(B$2:B$3))/4)"
.Columns(3).Formula =
"=NORMINV(RAND(),SUM(C$2:C$3)/2,
(MAX(C$2:C$3)-MIN(C$2:C$3))/4)"
.Columns(4).Formula = "=A4/130*B4*C4"
MsgBox "Now follow 10,000 runs with arrays:"
ReDim arr5Perc(0 To 9999): ReDim arr95Perc(0
To 9999)
Free ebooks ==> www.Ebook777.com
For i = 0 To 9999
.Calculate
arr5Perc(i) =
WorksheetFunction.Percentile(.Columns(4), 0.05)
arr95Perc(i) =
WorksheetFunction.Percentile(.Columns(4), 0.95)
Next i
End With
d5Perc = WorksheetFunction.Average(arr5Perc)
d95Perc = WorksheetFunction.Average(arr95Perc)
sMsg = "After 10,000 x 100 runs of monthly costs:"
& vbCr
sMsg = sMsg & "the 5th percentile is:" & vbTab &
vbTab
sMsg = sMsg & FormatCurrency(d5Perc, 2) &
vbCr & "the 95th percentile is:"
sMsg = sMsg & vbTab &
FormatCurrency(d95Perc, 2)
MsgBox sMsg
End Sub
www.Ebook777.com
Chapter 66: A Filtering Table
What the simulation does
Option Explicit
Sub Filtering()
Dim vArr As Variant, i As Integer, j As Integer,
sFilter As String
Dim oFilter As Range, oRange As Range
Range("G6").CurrentRegion.Delete xlShiftToLeft
With Range("A1").CurrentRegion
i = .Rows.Count
.Range(Cells(i + 2, 1), Cells(i + 3, 5)).Delete
xlShiftUp
MsgBox "Prepare the matrix and the filter"
.Columns(1).AdvancedFilter xlFilterCopy, ,
Range("G6"), True
.Columns(2).AdvancedFilter xlFilterCopy, ,
Range("H6"), True
Set oFilter = .Range(Cells(i + 2, 1), Cells(i + 3,
5))
oFilter.Rows(1) = .Rows(1).Value
End With
With Range("G6")
vArr = .CurrentRegion
.CurrentRegion.ClearContents
MsgBox "Fix the matrix"
For i = 2 To UBound(vArr, 1) '1 is label |
UBound(x,1) is 1st dimension
For j = 2 To UBound(vArr, 2) '1 is label |
UBound(x,2) is 2nd dimension
.Offset(i - 1, 0) = vArr(i, 1)
.Offset(0, i - 1) = vArr(i, 2)
Next j
Next i
MsgBox "Implement the filter"
Set oRange = Range("A1").CurrentRegion
.Cells(1, 1).Formula = "=DSUM(" &
oRange.Address & ",E1," & oFilter.Address & ")"
'E1 is the Totals label
.Cells(1, 1).CurrentRegion.Table Range("B28"),
Range("A28")
.Cells(1, 1).CurrentRegion.NumberFormat =
"$##0.00"
.Cells(1,
1).CurrentRegion.EntireColumn.AutoFit
End With
oFilter.Cells(2, 4) = InputBox("Sold filter (or
Cancel)", , ">400")
oFilter.Cells(2, 5) = InputBox("Total filter (or
Cancel)", , ">300")
End Sub
Chapter 67: Profit Changes
What the simulation does
Option Explicit
Sub Profits()
Dim oUnitPrice As Range, oCostPrice As Range,
oUnitsSold As Range
Dim oUnitAndCost As Range, oUnitAndSold As
Range
Dim pUnitPrice As Double, pCostprice As Double,
iSold As Long, vArr As Variant, i As Integer
vArr = Array("E3:F13", "H3:I13", "K3:L13",
"E16:I20", "E24:I28")
For i = 0 To UBound(vArr)
Range(vArr(i)).ClearContents
Next i
Sheet1.Protect , , , , True 'no changes on sheet
except throug macro (=true)
pUnitPrice = InputBox("Best estimate of the unit
price?", , 125)
Range("B2").Formula = "=(1+D2)*" & pUnitPrice
pCostprice = InputBox("Best estimate of the cost
price?", , 25)
Range("B6").Formula = "=(1+G2)*" & pCostprice
iSold = InputBox("Best estimate of items sold?", ,
100000)
Range("B3").Formula = "=(1+J2)*" & iSold
Set oUnitPrice = Range(vArr(0)).Offset(-1,
-1).Resize(Range(vArr(0)).Rows.Count + 1,
Range(vArr(0)).Columns.Count + 1)
Set oCostPrice = Range(vArr(1)).Offset(-1,
-1).Resize(Range(vArr(1)).Rows.Count + 1,
Range(vArr(1)).Columns.Count + 1)
Set oUnitsSold = Range(vArr(2)).Offset(-1,
-1).Resize(Range(vArr(2)).Rows.Count + 1,
Range(vArr(2)).Columns.Count + 1)
Set oUnitAndCost = Range(vArr(3)).Offset(-1,
-1).Resize(Range(vArr(3)).Rows.Count + 1,
Range(vArr(3)).Columns.Count + 1)
Set oUnitAndSold = Range(vArr(4)).Offset(-1,
-1).Resize(Range(vArr(4)).Rows.Count + 1,
Range(vArr(4)).Columns.Count + 1)
oUnitPrice.Table , Range("D2")
oCostPrice.Table , Range("G2")
oUnitsSold.Table , Range("J2")
oUnitAndCost.Table Range("G2"), Range("D2")
oUnitAndSold.Table Range("J2"), Range("D2")
End Sub
Chapter 68: Risk Analysis
What the simulation does
Option Explicit
Sub Risks()
Dim oRange As Range, oTable As Range, i As Long
Range("B10:E11").ClearContents
Range("C2").Formula =
"=VLOOKUP(RAND(),G2:H5,2,1)"
Set oRange = Range("B14").CurrentRegion
With oRange
Set oTable = .Offset(1, 1).Resize(.Rows.Count -
1, .Columns.Count - 1)
End With
oTable.ClearContents
i = InputBox("How many runs (1,000 - 100,000)?",
, 10000)
Set oRange = Range(Cells(13, 1), Cells(13 + i, 5))
oRange.Table Range("C1"), Range("G14")
i=i+3
Range("B10:E10").FormulaR1C1 =
"=AVERAGE(R14C:R[" & i & "]C)"
Range("B11:E11").FormulaR1C1 =
"=STDEV(R14C:R[" & i-1 & "]C)"
MsgBox "Results based on 1,000 x " & Format(i -
3, "#,##0") & " runs."
End Sub
Chapter 69: Scenarios
What the simulation does
Option Explicit
Sub Scenarios()
Dim vArr As Variant, i As Integer, sCombo As
String, iRow As Integer, oTable As Range
Range("C20:E27").ClearContents
Range("I14:L1013").ClearContents
i = InputBox("How many runs (100-1000)?", , 100)
Set oTable = Range(Cells(13, 8), Cells(13 + i, 12))
'Starts at $H$13
oTable.Table , Range("F11")
vArr = Array(135, 136, 145, 146, 235, 236, 245, 246)
For i = 0 To 7
sCombo = vArr(i)
Cells(2, 2) = Left(sCombo, 1): Cells(2, 4) =
Mid(sCombo, 2, 1): Cells(2, 6) = Right(sCombo, 1)
Application.Calculate
iRow =
WorksheetFunction.Match(CInt(sCombo),
Range("B20:B27"))
Range("C20:E27").Cells(iRow, 1) =
Range("L4")
Range("C20:E27").Cells(iRow, 2) =
Range("L6")
Range("C20:E27").Cells(iRow, 3) =
Range("L8")
Cells.EntireColumn.AutoFit
MsgBox "Results for scenarios " &
Range("K2")
Next i
End Sub
Free ebooks ==> www.Ebook777.com
When talking about GDP growth (Gross Domestic Product) and the
relationship between GDP growth and market growth, or the increase in
market share, we are dealing with three uncertain inputs. The obvious
approach is to use the best estimate for each of these inputs.
A better approach might be using a probability distribution, rather than
using the single best estimate. Monte-Carlo modelling would use the
probability distributions of the inputs. Rather than using the distributions
themselves as inputs, we use the distributions to generate random inputs.
Based on a certain market volume (cell D1) and a certain market share
(cell F1), the simulation calculates possible sales volumes (column G). It
uses random distributions in 100 to 1,000 runs to estimate GDP growth
(column A), the relationship between GDP and market size (column B), and
the market share growth (column E).
Then it repeats this set of runs another 100 to 1,000 times, in columns
J:K. After at least 10,000 runs, we get an rather good estimate of the
minimum and maximum sales volumes in column N. Needless to say that
these figures can still vary quite a bit, because Monte Carlo simulations
become more reliable when based on at least 1,000,000 runs.
www.Ebook777.com
What you need to know
The model we use is basically very simple:
• C3: market growth = GDP growth × multiple
• D3: market size = current size × (market growth + 1)
• F3: market share = current market share + gain
• G3: sales volumes = market size × market share
What you need to do
Option Explicit
Sub Market()
Dim i As Long, n As Long, oRange As Range,
oTable As Range
Set oRange = Range("B6").CurrentRegion
With oRange
Set oRange = .Offset(1, 0).Resize(.Rows.Count -
1, .Columns.Count)
End With
oRange.ClearContents
Set oTable = Range("J7").CurrentRegion
With oTable
Set oTable = .Offset(1, 1).Resize(.Rows.Count -
1, .Columns.Count - 4)
End With
oTable.ClearContents
i = InputBox("How many row calculations (100-
1000)?", , 100)
n = InputBox("How many table runs (100-1000)?",
, 100)
Range("J6") = i & "x" & n & " = " & i * n & "
calculations"
Set oRange = Range(Cells(7, 2), Cells(6 + i, 8))
oRange.Columns(1).Formula =
"=NORMINV(RAND(),$B$3,$B$4)"
oRange.Columns(2).Formula =
"=NORMINV(RAND(),$C$3,$C$4)"
oRange.Columns(3).Formula = "=B7*C7"
oRange.Columns(4).Formula = "=$D$1*(D7+1)"
oRange.Columns(5).Formula =
"=NORMINV(RAND(),$F$3,$F$4)"
oRange.Columns(6).Formula = "=$F$1+F7"
oRange.Columns(7).Formula = "=E7*G7"
Set oTable = Range(Cells(7, 10), Cells(6 + n, 11))
oTable.Cells(1, 1).Formula = "=AVERAGE(" &
oRange.Columns(7).Address & ")"
oTable.Cells(1, 2).Formula = "=AVERAGE(" &
oRange.Columns(7).Address & ")"
oTable.Table , Range("I6")
Range("N7").Formula = "=MIN(" &
oTable.Columns(2).Address & ")"
Range("N8").Formula = "=MEDIAN(" &
oTable.Columns(2).Address & ")"
Range("N9").Formula = "=MAX(" &
oTable.Columns(2).Address & ")"
Range("J6") = "Results of " & i & " x " & n & "
runs."
MsgBox Range("J6")
End Sub
Chapter 71: A Traffic Situation
What the simulation does
Option Explicit
Sub TrafficCommute()
Dim oRange As Range, oTable As Range
Dim sMsg As String, pMedian As Double, pAvg As
Double
Set oRange = Range("A1").CurrentRegion
With oRange
Set oRange = .Offset(1, 0).Resize(.Rows.Count -
1, .Columns.Count)
End With
oRange.ClearContents:
Range("I9:J19").ClearContents
MsgBox "New calculations"
oRange.Columns(1).Formula = "=IF(RAND() <
0.9, 111, 360)"
oRange.Columns(2).Formula = "=MAX(0,
(RAND() * 120) - 30)"
oRange.Columns(3).Formula =
"=VLOOKUP(RAND(),$H$2:$I$5, 2)"
oRange.Columns(4).Formula = "=SUM(A2:C2)"
oRange.Columns(5).Formula = "=D2/60"
Range("I8").Formula = "=MEDIAN(E:E)":
Range("J8").Formula = "=AVERAGE(E:E)"
Set oTable = Range("H8:J19")
oTable.Table , Range("G7")
With oTable
sMsg = "For 1000 x 12 runs:" & vbCr
pMedian =
FormatNumber(WorksheetFunction.Median(.Columns(2)),
3)
sMsg = sMsg & "Median: " & vbTab & pMedian
& " mins." & vbCr
pAvg =
FormatNumber(WorksheetFunction.Average(.Columns(3)),
3)
sMsg = sMsg & "Average: " & vbTab & pAvg &
" mins." & vbCr
End With
MsgBox sMsg
End Sub
Chapter 72: Quality Control
What the simulation does
Here we are dealing with an assembly line that creates between 100
and 1,000 products (B1) per period of time. One particular variable of this
product is supposed to be close to a value of 15 (B2) but is allowed to vary
with a SD of 2 (B3), as shown some 1,000 times in column A.
To ensure quality, we take a certain percentage of samples (E1) in
which we accept 2% defects (E2, or whatever is in there). Based on such a
sample we decide, with 95% confidence (E3), to accept or reject the entire
production lot.
Since this process is far from certain but depends heavily on
probabilities, we repeat this process a number of times in the Data Table far
to the right.
At the end of the simulation, the macro reports several averages in a
MsgBox.
What you need to know
In cell D8, the VBA code inserts the following formula (copied down
to E1007):
=IF(AND(ROW(D7)+1<=($B$1+7),COUNT($D$7:D7)
<($B$1*$E$1)),IF(RAND()<=$E$1,A8,""),"")
In cell E8: =IF(D8<>"",IF((ABS($B$2-
D8)/$B$3)>1.96,"reject","OK"),"")
The function used in G6 is CRITBINOM. It determines the greatest
number of defective parts that are allowed to come off an assembly line
sample without rejecting the entire lot. It has 3 arguments: The number of
trials, the probability of a success on each trial, and the criterion value
(alpha). Recently, this function has been replaced with BINOM.INV.
What you need to do
Option Explicit
Sub QualityControl()
Dim oRange As Range, oTable As Range, sFormula
As String, sMsg As String
Dim pAvgProd As Double, pAvgSampl As Double,
pAvgCount As Double, iReject As Integer
Set oRange = Range("D8:E1007")
With oRange
.ClearContents
sFormula = "=IF(AND(ROW(D7)+1<=
($B$1+7),COUNT($D$7:D7)
<($B$1*$E$1)),IF(RAND()<=$E$1,A8,""""),"""")"
'double quotes inside double quotes
.Columns(1).Formula = sFormula
sFormula = "=IF(D8<>"""",IF((ABS($B$2-
D8)/$B$3)>1.96,""reject"",""OK""),"""")"
.Columns(2).Formula = sFormula
End With
Set oTable = Range("J3").CurrentRegion
With oTable
Set oTable = .Offset(3, 1).Resize(.Rows.Count -
3, .Columns.Count - 1)
End With
With oTable
.ClearContents
Set oTable = .Offset(-1, -1).Resize(.Rows.Count +
1, .Columns.Count + 1)
oTable.Table , Range("I1")
End With
With oTable
pAvgProd =
WorksheetFunction.Average(.Columns(2))
pAvgSampl =
WorksheetFunction.Average(.Columns(3))
pAvgCount =
WorksheetFunction.Average(.Columns(4))
iReject =
WorksheetFunction.CountIf(.Columns(7), "reject")
End With
sMsg = "The mean or average of 22x1000 runs:" &
vbCr
sMsg = sMsg & "all products: " & vbTab &
FormatNumber(pAvgProd, 4) & vbCr
sMsg = sMsg & "all samples: " & vbTab &
FormatNumber(pAvgSampl, 4) & vbCr
sMsg = sMsg & "all sample counts: " & vbTab &
FormatNumber(pAvgCount, 4) & vbCr
sMsg = sMsg & "number of rejects: " & vbTab &
iReject
MsgBox sMsg
End Sub
Chapter 73: Waiting Time Simulation
What the simulation does
Option Explicit
Sub WaitingTime()
Dim oRange As Range, iMaxVisitTime As Integer,
arrVisTime() As Integer, i As Integer, n As Long
Set oRange = Range("B7:G16")
With oRange
.ClearContents
.Columns(1).Formula =
"=VLOOKUP(RAND(),$A$2:$B$4,2,TRUE)"
.Columns(2).Formula = "=SUM($B$7:B7)"
.Columns(3).Cells(1, 1).Formula = "=C7"
Range("D8:D16").Formula =
"=IF(C8<F7,F7,F7+(C8-F7))"
.Columns(4).Formula =
"=VLOOKUP(RAND(),$E$2:$F$4,2,TRUE)"
.Columns(5).Formula = "=D7+E7"
.Columns(6).Formula = "=F7-C7"
.Calculate
End With
n = InputBox("How many runs (100-1000)?", , 100)
ReDim arrVisTime(0 To n - 1)
For i = 0 To n - 1
Range("B7:G19").Calculate
iMaxVisitTime = Range("G19")
arrVisTime(i) = iMaxVisitTime
Next i
MsgBox "After " & n & " runs, the average of " &
vbCr & _
"maximum wait times is " &
WorksheetFunction.Average(arrVisTime) & " mins."
End Sub
Chapter 74: Project Delays
What the simulation does
Option Explicit
Sub ProjectDelays()
Dim oTable As Range, i As Integer, sMsg As String,
dAvgDate As Date, iOff As Long
With Range("E2:H11")
.ClearContents
.Columns(1).Formula = "=C2+D2-1"
.Columns(2).Formula =
"=D2+RANDBETWEEN(-2,2)"
.Columns(3).Formula = "=IF(ROW()=2,C2,
H1+1)"
.Columns(4).Formula = "=G2+F2-1"
End With
Set oTable = Range("G14").CurrentRegion
Range("H15:H115").ClearContents
oTable.Table , Range("F13")
Range("E14:E33") =
WorksheetFunction.Frequency(oTable.Columns(2),
Range("D14:D33"))
'OR: Range("E14:E33").FormulaArray =
"=FREQUENCY(R14C8:R115C8,R14C4:R33C4)"
dAvgDate =
Round(WorksheetFunction.Average(oTable.Columns(2)),
0)
iOff = WorksheetFunction.Days(dAvgDate,
Range("E11")) '+ IIf(iOff >= 0, 1, -1)
If dAvgDate = Range("E11") Then iOff = 0
sMsg = "Average finish date of 100 runs: " &
FormatDateTime(dAvgDate, vbShortDate) & vbCr
sMsg = sMsg & "On average " & Abs(iOff) & "
days " & IIf(iOff >= 0, "later", "earlier")
sMsg = sMsg & " than " & Range("E11")
MsgBox sMsg
End Sub
VII. FINANCE
Chapter 75: Buy or Sell Stock?
What the simulation does
Option Explicit
Sub BuySell()
Dim i As Long, oCurReg As Range, oRange As
Range, iOffset As Long, n As Long
Dim pAvg As Double, pSD As Double, arrVal() As
Double, sMsg As String, sVerdict As String
Dim pAvgAvg As Double, pLatestVal As Double
Set oCurReg = Range("A1").CurrentRegion
With oCurReg
iOffset = oCurReg.Rows.Count
pLatestVal = .Cells(iOffset, 2)
For i = iOffset To 2 Step -5
Set oRange = .Range(Cells(iOffset - i + 1, 2),
Cells(iOffset, 2))
pAvg = WorksheetFunction.Average(oRange)
pSD = WorksheetFunction.StDev(oRange)
ReDim arrVal(0 To 9999)
For n = 0 To 9999
arrVal(n) =
WorksheetFunction.Norm_Inv(Rnd, pAvg, pSD)
Next n
pAvgAvg =
WorksheetFunction.Average(arrVal)
sVerdict = IIf(pAvgAvg > (pLatestVal + pSD *
0.01), "buy", IIf(pAvgAvg < (pLatestVal - pSD * 0.01),
"sell", "-"))
sMsg = sMsg & "Latest " & i & vbTab &
pAvgAvg & vbTab & sVerdict & vbCr
Next i
MsgBox sMsg
End With
End Sub
Chapter 76: Moving Averages
What the simulation does
This file has 3 sheets and 3 similar macros for “moving averages” and
“exponential smoothing.” It simulates what happens when we reduce the
amount of “noise” with a certain factor.
What you need to know
What you need to do
Sub MovingAverage()
Dim oChart As Chart, oSelect As Range, oSeries
As Series
Dim oTrendCol As Trendlines, oTrend As Trendline
Sheet12.Activate: Range("A1").Select
Set oSelect = ActiveCell.CurrentRegion : Set
oChart = Charts.Add
oChart.SetSourceData oSelect
oChart.ChartType = xlXYScatterLines
oChart.HasLegend = False: oChart.HasTitle =
False
oChart.Axes(xlCategory).HasMajorGridlines =
True
oChart.Location xlLocationAsNewSheet
Set oSeries = oChart.SeriesCollection(1)
Set oTrendCol = oSeries.Trendlines
Set oTrend = oTrendCol.Add(xlMovingAvg, ,
InputBox("Period", , 3))
oTrend.Border.LineStyle = xlDot :
Application.DisplayAlerts = False
If MsgBox("Delete?", vbYesNo) = vbYes Then
oChart.Delete
Application.DisplayAlerts = True
End Sub
Sub AvgSmoothed()
Dim i As Integer, oRange As Range
Sheet10.Activate: Range("A1").Select
i = InputBox("Number of intervals to be
averaged", , 2)
With Range("C1")
.Value = "Avg on " & i
Set oRange = .Range(Cells(2, 1),
Cells(.CurrentRegion.Rows.Count, 1))
oRange.Clear
Set oRange = .Range(Cells(i + 1, 1),
Cells(.CurrentRegion.Rows.Count, 1))
oRange.FormulaR1C1 = "=AVERAGE(RC[-1] :
R[-" & i - 1 & "]C[-1])"
oRange.NumberFormat = "0.00"
End With
End Sub
Sub Damping()
Dim pDamp As Double, oRange As Range
Sheet11.Activate: Range("A1").Select
pDamp = InputBox("Damping factor", , 0.15)
With Range("C1")
.Value = pDamp : .Offset(1, 0).Formula =
"=B2"
Set oRange = .Range(Cells(3, 1),
Cells(.CurrentRegion.Rows.Count, 1))
oRange.Clear
Set oRange = .Range(Cells(3, 1),
Cells(.CurrentRegion.Rows.Count, 1))
oRange.Formula = "=$C$1*B2+(1-$C$1)*C2"
oRange.NumberFormat = "0.00":
oRange.Font.Bold = True
End With
End Sub
Chapter 77: Automatic Totals and
Subtotals
What the simulation does
At the bounds of the database A1:E13, the first macro, Totals, adds
summaries of your choosing—SUM, STDEV, MEDIAN, and so on. The
second macro, SubTotals, creates subtotals and lets the users determine
which columns they like to use for sorting and summing. Then it offers the
option to copy this summary of subtotals to a new sheet.
What you need to know
The macro assumes that your database does not have formulas in it, so
it can use the VBA property HasFormula to determine where the database
ends.
What you need to do
Sub Subtotals()
Dim oSelect As Range, oSort As Range, oTotal As
Range, oWS As Worksheet
Sheet1.Activate: Range("A1").Select
With ActiveCell.CurrentRegion
Set oSort = Application.InputBox("Sort by
Label", , "G1", , , , , 8)
.Sort oSort, xlAscending, , , , , , xlYes
Set oTotal = Application.InputBox("SUM by
Label", , "D1", , , , , 8)
.Subtotal oSort.Column, xlSum,
Array(oTotal.Column)
Set oWS = ActiveSheet
ActiveSheet.Outline.ShowLevels 2 '[row-levels],
[col-levels]
Set oSelect = Application.InputBox("Which
range to copy", , Range("D1:D24,G1:G24").Address,
, , , , 8)
Set oSelect =
oSelect.SpecialCells(xlCellTypeVisible)
Set oWS = Worksheets.Add(, ActiveSheet)
oSelect.Copy Cells(1, 1) : oSelect.Font.Color =
vbRed
oSelect.Rows(1).Font.Color = vbBlack
.EntireColumn.AutoFit:
Cells().EntireColumn.AutoFit
Application.CutCopyMode = False ;
.Range("A1").RemoveSubtotal
End With
End Sub
Sub Totals()
Dim r As Long, c As Long, sOper As String,
oRange As Range, oCurReg As Range, n As Integer
Sheet2.Select: Range("A1").Select
With ActiveCell.CurrentRegion
r = .Rows.Count: c = .Columns.Count
If .Cells(r, c).HasFormula = False Then
.BorderAround , xlThick
sOper =
InputBox("SUM/AVERAGE/MAX/STDEV/MODE/MEDIAN/CO
, "SUM")
sOper = UCase(sOper)
Do Until .Cells(r, c).HasFormula = False
r = r - 1: c = c - 1: n = n + 1
Loop
If n > 0 Then
If MsgBox("Add " & sOper & " (instead of
replace)?", vbYesNo) = vbYes Then
r = r + n: c = c + n
End If
End If
.Cells(1, c + 1) = sOper: .Cells(r + 1, 1) = sOper
Set oRange = .Range(.Cells(r + 1, 2), .Cells(r + 1,
c))
oRange.FormulaR1C1 = "=" & sOper & "
(R2C:R[-" & n + 1 & "]C)"
oRange.NumberFormat = .Cells(r,
c).NumberFormat
Set oRange = .Range(.Cells(2, c + 1), .Cells(r +
1, c + 1))
oRange.FormulaR1C1 = "=" & sOper & "
(RC2:RC[-1])"
oRange.NumberFormat = .Cells(r,
c).NumberFormat
If MsgBox("Delete summary?", vbYesNo) =
vbYes Then
With Range("B2").CurrentRegion
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).HasFormula Then
.Rows(r).ClearContents
Next r
For c = .Columns.Count To 1 Step -1
If .Cells(2, c).HasFormula Then
.Columns(c).ClearContents
Next c
End With
End If
End With
End Sub
Chapter 78: Fluctuations of APR
What the simulation does
Let’s pretend we are trying to predict what the total return would be
over a period of years if the initial deposit is fixed and the annual percentage
rate (APR) is fluctuating. So this sheet calculates how a fixed deposit
compounds over a specific number of years with a fluctuating APR.
We use three tables to set up this calculation. In the left table, we set up
our parameters and use a simple calculation of return without considering
any volatility. In the middle table, we simulate how APR could fluctuate
during the time period—in this case 30 years—if the volatility is 0.3% (cell
B4). Since this middle table represents only one of the many possible
outcomes, we need to run additional scenarios to model fluctuations in
return. In the Data Table to the right, we run these additional scenarios of the
middle table some 25 times.
The macro summarizes the results of 25 runs for what your savings
would be after 30 years—minimum, average, and maximum.
What you need to know
Compounding a certain amount of
money is based on a very simple formula: the starting amount multiplied by
(1+APR) raised to the power of the number of years—or: X*(1+APR)^yrs.
This is the formula used in the left table.
The middle table uses the function NORMINV to simulate fluctuations
in the annual percentage rate each year.
The Data Table to the right runs the end result of the middle table at
least 25 times by using the array formula {=TABLE(,G1)}—pointing to any
empty cell outside the table (e.g., cell G1). The more runs, the more reliable
the outcome is.
The chart is linked to columns D:F. One curve, the upward one, is for
the compounding savings amount; the other curve shows APR fluctuations.
What you need to do
Option Explicit
Sub Savings()
Dim oRange As Range, oTable As Range,
oFormulas As Range, n As Integer
Dim sMsg As String, sMin As String, sMax As
String, sAvg As String
Set oRange = Range("D1").CurrentRegion
oRange.ClearContents
Set oTable = Range("H1").CurrentRegion
oTable.ClearContents
n = InputBox("For how many years (max of 30)?",
, 30)
If n > 30 Then Exit Sub Else Range("B2") = n
Set oRange = Range("D1").Range(Cells(1, 1),
Cells(n + 1, 3))
oRange.Cells(1, 1) = "Year": oRange.Cells(1, 2) =
"APR": oRange.Cells(1, 3) = "Savings"
Set oFormulas = oRange.Range(Cells(2, 1), Cells(n
+ 1, 3))
With oFormulas
.Columns(1).Formula = "=ROW(A1)"
.Columns(2).Formula =
"=NORMINV(RAND(),$B$3,$B$4)"
.Columns(3).Cells(1, 1).Formula = "=$B$1*
(1+E2)^D2"
.Columns(3).Range(Cells(2, 1), Cells(n,
1)).Formula = "=F2*(1+E3)"
oTable.Cells(1, 2).Formula = "=" &
.Columns(3).Cells(n, 1).Address
End With
Set oTable = Range("H1").Range(Cells(1, 1),
Cells(26, 2))
oTable.Table , Range("G1")
With oTable
sMin =
FormatCurrency(WorksheetFunction.Min(.Columns(2)),
2)
sAvg =
FormatCurrency(WorksheetFunction.Average(.Columns(2)),
2)
sMax =
FormatCurrency(WorksheetFunction.Max(.Columns(2)),
2)
End With
sMsg = "Minimum savings: " & vbTab & sMin &
vbCr
sMsg = sMsg & "Average savings: " & vbTab &
sAvg & vbCr
sMsg = sMsg & "Maximum savings: " & vbTab &
sMax & vbCr
MsgBox sMsg
End Sub
Chapter 79: Net Present Value
What the simulation does
When you have three scenarios (likely, best, worst) for your costs,
benefits, and growth rate (in A1:D4), you probably want a random outcome
between the extremes of best and worst. Then ultimately you want to
calculate the net present value (NPV) of your cash flows (in cell K10).
Here is some terminology. Having projected a company’s free cash
flow for the next five years, you want to figure out what these cash flows are
worth today. That means coming up with an appropriate discount rate which
you can use to calculate the net present value (NPV) of the cash flows. A
discount rate of 5% is used in column I (see screen shot below).
The most widely used method of discounting is exponential
discounting, which values future cash flows as “how much money would
have to be invested currently, at a given rate of return, to yield the cash flow
in the future.”
After running your 5 year projection (H1:K8), the simulation repeats
this with some 10,000 runs ithrough a VBA array. The simulation calculates
the average NPV and its standard deviation in cell K10 and K11 for the
latest run. The MsgBox keeps track of the results for previous runs.
Based on this information, you may want to find out what the
distribution of NPV values would be given the average of K10 and the
standard deviation of K11. This is done below them in cells J17:K51,
ranging from 2.5% to 97.5%. The graph shows the results, with the
“average” featuring at 50% (see screen shot on the next page).
What you need to know
What you need to do
Option Explicit
Sub NPV()
Dim i As Long, n As Long, pNPV As Double,
arrNPV() As Double, sMsg As String
Dim pSum As Double, pAvg As Double, pSD As
Double, sAvg As String, sSD As String
n = InputBox("How many iterations (1000 to
10,000)?", , 1000)
sMsg = "After " & n & " calculations:" & vbCr
Do
ReDim arrNPV(0 To n - 1)
For i = 0 To n - 1
Range("A1:K8").Calculate
arrNPV(i) = Range("K8")
pSum = pSum + arrNPV(i)
Next i
pAvg = pSum / n: sAvg =
FormatCurrency(pAvg, 2): pSum = 0
pSD = WorksheetFunction.StDev_S(arrNPV):
sSD = FormatCurrency(pSD, 2)
Range("K10") = sAvg: Range("K11") = sSD
sMsg = sMsg & "Mean NPV:" & sAvg & vbTab
& vbTab & "SD NPV:" & vbTab & sSD & vbCr
Loop Until MsgBox(sMsg & vbCr & "Repeat?",
vbYesNo) = vbNo
End Sub
Chapter 80: A Loan with Balance
and Principal
What the simulation does
Sub Loan()
Dim cLoan As Currency, pAPR As Double,
iDuration As Integer, i As Integer
Dim oWS As Worksheet
cLoan = InputBox("Loan amount", , 65000)
pAPR = InputBox("Fixed APR", , 0.056) / 12
iDuration = InputBox("Number of years", , 30) *
12
Set oWS = Worksheets.Add(, ActiveSheet)
oWS.Name = cLoan & "-" &
FormatPercent(pAPR, 2) & "-" & iDuration
Cells(1, 1) = "Period"
Cells(1, 2) = "Month"
Cells(1, 3) = "Balance"
Cells(1, 4) = "Monthly"
Cells(1, 5) = "Interest"
Cells(1, 6) = "Principal"
Cells(1, 7) = "Cum. Interest"
Cells(1, 8) = "Cum. Principal"
Application.Cursor = xlWait
With Range("A1")
For i = 1 To iDuration
.Offset(i, 0).Formula = "=ROW()-1"
'=DATE(YEAR(B5),MONTH(B5)+1,1)
.Offset(i, 1).Formula =
"=DATE(YEAR(TODAY()), MONTH(TODAY())+" &
i & ",1)"
.Offset(i, 1).NumberFormat = "mmm-yy"
'=Loan and then =C3+F3
.Offset(i, 2).FormulaR1C1 = IIf(i = 1, cLoan,
"=R[-1]C3+R[-1]C6")
'=PMT(pAPR,iDuration,cLoan)
.Offset(i, 3).Formula = "=PMT(" & pAPR &
"," & iDuration & "," & cLoan & ")"
'=IPMT(pAPR,period,iDuration,cLoan)
.Offset(i, 4).FormulaR1C1 = "=IPMT(" &
pAPR & ",RC1," & iDuration & "," & cLoan & ")"
'=PPMT(pAPR,period,iDuration,cLoan)
.Offset(i, 5).FormulaR1C1 = "=PPMT(" &
pAPR & ",RC1," & iDuration & "," & cLoan & ")"
'=SUM($E$2:E2)
.Offset(i, 6).FormulaR1C1 =
"=SUM(R2C5:RC5)"
'=SUM($F$2:F2)
.Offset(i, 7).FormulaR1C1 =
"=SUM(R2C6:RC6)"
Next i
End With
Cells.EntireColumn.AutoFit
Application.Cursor = xlDefault
End Sub
Chapter 81: S&P500 Performance
What the simulation does
Option Explicit
Sub Performance()
Dim oRange As Range, arrVals() As Double, i As
Long, n As Integer
Dim pAvg As Double, pSD As Double, sMsg As
String
Do
ReDim arrVals(0 To 9999)
n=n+1
For i = 0 To 9999
Range("E2:F6").Calculate
arrVals(i) = (Cells(6, 5) + 1) * (Cells(5, 6) + 1)
-1
Next i
pAvg = WorksheetFunction.Average(arrVals)
pSD = WorksheetFunction.StDev(arrVals)
sMsg = sMsg & "Average: " &
FormatPercent(pAvg, 3) & vbTab & _
"SD: " & FormatPercent(pSD, 3) & vbCr
MsgBox n & " x 10,000 runs:" & vbCr & sMsg
Loop Until MsgBox("Another run?", vbYesNo) =
vbNo
End Sub
Chapter 82: Stock Market
What the simulation does
The left section of this sheet contains hard-coded data, comparing past
S&P 500 values (C) with the past values of a traditional portfolio (B).
The right section analyses this information from the most recent month
(12/1/06) down to the previous month (11/1/06) and much further back in
time, if needed. The overview “grows” back in time if you copy its first row
down as far as you want to go back in history.
In addition, when new records are added at the bottom of the left
section, the first row in the right section will automatically update the history
from the most recent data down.
The macro does all of this automatically, once you decide on the
number of rows “back in history.”
What you need to know
The only new function is COUNTA. The COUNTA function works
like COUNT, but it also counts cells with text in them, such as the headers
above each column.
As said before, the function INDEX is a more sophisticated version of
VLOOKUP. It looks in a table at a certain row position and a certain column
position. It uses this syntax: INDEX(table, row#, col#). Whereas VLOOKUP
works only with column numbers, INDEX also uses row numbers, which is
very important when we want to look at a record that is located, for
instance, 3 or 12 rows above another record (like in columns G and J).
This time we use the function ROW again, but for a different reason—
to make the month go down: row# – ROW(A1)+1. Each time we copy that
formula one row down, the formula subtracts one more row: – ROW(A2),
then – ROW(A3), and so forth.
What you need to do
Option Explicit
Sub Stock()
Dim oRange As Range, oTable As Range
Dim vArr As Variant, i As Long, n As Long
vArr = Array("Month", "Traditional", "Trad-
3mo", "BenchMark", "S&P500", "S&P-3mo",
"BenchMark")
Set oRange = Range("A1").CurrentRegion
Set oTable = Range("E1").CurrentRegion
oTable.Clear
Range("E1:K1") = vArr
n = InputBox("How many months?", , 12)
Set oTable = Range(Cells(2, 5), Cells(1 + n, 11))
With oTable
.Columns(1).Formula =
"=INDEX($A:$C,COUNTA($A:$A)-ROW(A1)+1,1)"
.Columns(2).Formula =
"=INDEX($A:$C,COUNTA($A:$A)-ROW(B1)+1,2)"
.Columns(3).Formula =
"=INDEX($A:$C,COUNTA($A:$A)-ROW(C1)+1-
3,2)"
.Columns(4).Formula = "=F2/G2-1"
.Columns(5).Formula =
"=INDEX($A:$C,COUNTA($A:$A)-ROW(A1)+1,3)"
.Columns(6).Formula =
"=INDEX($A:$C,COUNTA($A:$A)-ROW(A1)+1-
3,3)"
.Columns(7).Formula = "=I2/J2-1"
For i = 2 To .Columns.Count
.Columns(i).Cells.NumberFormat = "0.00"
Next i
.Columns(1).Cells.NumberFormat = "m/d/yy"
.BorderAround , xlThick
.Cells.Font.Bold = True
End With
End Sub
Chapter 83: Stock Volatility
What the simulation does
Option Explicit
Sub Volatility()
Dim oRange As Range, i As Long, n As Long, c As
Integer, j As Integer
Dim arrVals() As Double, oTotals As Range
Set oRange = Range("A7").CurrentRegion
oRange.ClearContents
n = InputBox("How many days ahead (10-250)?", ,
250)
If n > 250 Then Exit Sub Else n = n + 1
Range("B2").Activate
With oRange
.Cells(1, 2) = "value": .Cells(1, 3) = "base":
.Cells(2, 2).Formula = "=B2"
.Range(Cells(2, 1), Cells(n, 1)).Formula =
"=ROW(A1)"
.Range(Cells(3, 2), Cells(n, 2)).Formula =
"=B7+B7*($B$3+$B$4*NORMINV(RAND(),0,1))"
.Range(Cells(2, 3), Cells(n, 3)).Formula =
"=$B$7"
End With
Set oTotals = Range(Cells(20, 6), Cells(20, 18))
oTotals.ClearContents
With oTotals
For c = 10 To n Step 20
ReDim arrVals(0 To 9999)
For i = 0 To 9999
oRange.Calculate
arrVals(i) =
WorksheetFunction.VLookup(c,
oRange.Range(Cells(2, 1), Cells(n, 2)), 2, True)
Next i
j=j+1
.Cells(1, j) =
WorksheetFunction.Average(arrVals)
Calculate
DoEvents
Next c
End With
End Sub
Chapter 84: Return on Investment
What the simulation does
Option Explicit
Sub CDReturn()
Dim i As Integer, oTable As Range
Range("B6:B11").ClearContents
Range("D6").CurrentRegion.Clear
i = InputBox("For how many years?", , 10)
Range("B6") = i
Range("B7").Formula = "=B1*(1-B4)^B6"
Range("B8").Formula = "=B1-B7"
Range("B9").Formula = "=B1*B2*B6"
Range("B10").Formula = "=B9*B3"
Range("B11").Formula = "=(B9-B8-
B10)/(B1+B8)"
Set oTable = Range(Cells(6, 4), Cells(13, 11))
With oTable
.Cells(1, 1).Formula = "=B11"
.Range(Cells(1, 2), Cells(1, 8)).Formula =
"=COLUMN(D1)/100"
.Range(Cells(1, 2), Cells(1,
8)).Borders(xlEdgeBottom).Weight = xlMedium
.Range(Cells(2, 1), Cells(8, 1)).Formula =
"=ROW(A4)/100"
.Range(Cells(2, 1), Cells(8,
1)).Borders(xlEdgeRight).Weight = xlMedium
.Table Range("B2"), Range("B4")
.Cells.NumberFormat = "0.00%;[Red] -0.00%"
.Cells(8, 1).Offset(1, 0) = "inflation rate"
.Cells(1, 8).Offset(0, 1) = "CD interest"
End With
End Sub
Chapter 85: Value at Risk
What the simulation does
Sub TableBox()
Dim cPort As Currency, pAvg As Double, pSD As
Double, pConf As Double
Dim sStart As String, i As Integer, oRange As
Range
Range("A6").CurrentRegion.ClearContents
cPort = InputBox("Portfolio", , Cells(1, 2)):
Cells(1, 2) = cPort
pAvg = InputBox("Average", , Cells(2, 2)):
Cells(2, 2) = pAvg
pSD = InputBox("Standard Deviation", , Cells(3,
2)): Cells(3, 2) = pSD
pConf = InputBox("Confidence Level", , 0.95):
Cells(4, 2) = pConf
sStart = InputBox("Start table in", , "A6")
If Range(sStart) <> "" Then
Range(sStart).CurrentRegion.Delete
With Range(sStart)
.Offset(0, 0) = "Confidence": .Offset(0, 1) =
"Min. return"
.Offset(0, 2) = "New value": .Offset(0, 3) =
"Value at risk"
.Offset(0, 4) = "Monthly VaR"
For i = 1 To 10
.Offset(i, 0) = FormatPercent(pConf - (i - 1) *
0.05, 0)
Next i
.Offset(1, 1).Formula = "=NORM.INV(1-
B4,B2,B3)"
.Offset(1, 2).Formula = "=B1*(" & .Offset(1,
1).Address & "+1)"
.Offset(1, 3).Formula = "=B1-" & .Offset(1,
2).Address
.Offset(1, 4).Formula = "=" & .Offset(1,
3).Address & "*SQRT(22)"
Set oRange = Range(.Offset(1, 0), .Offset(10, 4))
; oRange.Table , Range("B4")
oRange.Columns(2).NumberFormat = "0.00"
oRange.Columns(3).NumberFormat =
"$#,##0.00_);[Red]($#,##0.00)"
oRange.Columns(4).NumberFormat =
"$#,##0.00_);[Red]($#,##0.00)"
oRange.Columns(5).NumberFormat =
"$#,##0.00_);[Red]($#,##0.00)"
Cells.Columns.AutoFit
End With
'Conditional Formatting with Bars (only in later
versions of Excel)
With oRange.Columns(5)
Dim oBar As Databar
.Select
Set oBar =
Selection.FormatConditions.AddDatabar
oBar.MinPoint.Modify
newtype:=xlConditionValueAutomaticMin
oBar.MaxPoint.Modify
newtype:=xlConditionValueAutomaticMax
oBar.BarFillType = xlDataBarFillGradient
oBar.Direction = xlContext
oBar.NegativeBarFormat.ColorType =
xlDataBarColor
oBar.BarBorder.Type = xlDataBarBorderSolid
oBar.NegativeBarFormat.BorderColorType =
xlDataBarColor
oBar.AxisPosition = xlDataBarAxisAutomatic
End With
Range("B1").Select
End Sub
Chapter 86: Asian Options
What the simulation does
Option Explicit
Sub AsianOption()
Dim arrPayoffs() As Double, i As Long
Dim pAvg As Double, pSD As Double, pSE As
Double
Dim sLower As String, sUpper As String, sAvg As
String, sSD As String
ReDim arrPayoffs(0 To 99999)
For i = 0 To 99999
Range("B7:J7").Calculate
arrPayoffs(i) = Range("J7")
Next i
pAvg = WorksheetFunction.Average(arrPayoffs)
pSD = WorksheetFunction.StDev(arrPayoffs)
pSE = pSD / Sqr(100000)
sLower = FormatCurrency(pAvg - (1.96 * pSE), 2)
sUpper = FormatCurrency(pAvg + (1.96 * pSE), 2)
MsgBox "After 100,000 runs, we have " & vbCr &
"95% confidence that the payoff is:" & _
vbCr & "between:" & vbTab & sLower &
vbCr & "and:" & vbTab & sUpper
End Sub
VIII. MISCELLANEA
Chapter 87: Cracking a Password
What the simulation does
This is not a real password cracker, of course, but we can still mimic
part of the process. First of all, in real life you don’t know the password yet.
Second, the password can be, and should be, rather long. Neither condition
can be met in this simulation.
Let us assume that the password is “p@s.” This is a 3-letter word, so
even if we only use the characters a-z (no capitals), then we would still have
26^3 possible combinations—which amounts to 17,576 different
arrangements. But we would like to use other characters as well. So don’t
make the password longer than 3 characters, for that could take an enormous
amount of processing time. Even in the simple example shown above, we
were “lucky enough” to find one matching combination after 479,657 trials.
Run times may vary considerably, of course.
What you need to know
There is a VBA function called Chr (in Excel it’s the CHAR function)
which returns the character that comes with a certain asci number. To find
out what the asci number of a certain key is, we could use the VBA function
Asc (in Excel it’s the CODE function); for instance, Chr(“a”) would give us
the number 97.
The sheet shows 125 asci numbers in column A and the corresponding
characters in B, just for your information. To limit ourselves to “readable”
characters, we use the Excel function RANDBETWEEN to get a random
character between the asci-numbers 33 and 122
The macro also uses the Application.StatusBar property to report
progress on the status bar after every 1,000 runs.
What you need to do
Option Explicit
Sub Password()
Dim i As Long, j As Integer, sPass As String,
sGuess As String
sPass = InputBox("Which password?", "Watch the
Status Bar", "p@s")
'More than 3 chars could take very long
If Len(sPass) > 3 Then MsgBox "No more than 3
chars": Exit Sub
Range("A1").Select
Do
For j = 1 To Len(sPass)
sGuess = sGuess &
Chr(WorksheetFunction.RandBetween(33, 122))
Next j
If sGuess = sPass Then Exit Do
i=i+1
DoEvents
If i Mod 1000 = 0 Then Application.StatusBar =
i & " runs"
sGuess = ""
Loop
MsgBox "Found the password " & sPass & " after
" & i & " trials."
End Sub
Chapter 88: Encrypting Text
What the simulation does
This file has two sheets. It uses two different macros: one for the 1st
sheet, and the other for the 2nd sheet. They both encrypt and decrypt cells—
in this case cells with Social Security numbers (SSN). Both macros use a
costom function that I gave the name Encrypt (the first code on the next
page). This function has been given two arguments, the second of which is
Boolean and determines whether to encrypt the SSN or decrypt the
encrypted SSN. In the former case, it shifts asci numbers up by 20 (or so); in
the latter case it shifts them down by that amount. Obviously, it is one of the
simplest algorithms one could think of.
The difference between macros (Sub) and functions (Function) is a bit
semantic. Functions return something—a word, a value—just like the
function SUM returns the total of values. Subs, on the other hand, change
things. Let’s leave it at that.
The first macro (the second code on the next page) places in column D
of the 1st sheet an encrypted SSN, and then decrypts it again in column E. It
does so by setting the Formula property of those cells that uses the function
Encrypt.
The second macro (the third code on the next page) does something
similar, but this time by directly calling the Encrypt function.
What you need to know
To make the encrypted version a bit harder to crack, we used the VBA
function StrReverse, which puts the text, a String, in a reversed order.
What you need to do
Option Explicit
'A simple algorithm, so if law enforcement detects
illegal use of it, the code can be cracked easily
Sub CreateFormulas()
Dim iRows As Long
Sheet1.Activate: Range("A1").Select
iRows = Range("A1").CurrentRegion.Rows.Count
Range("D1").Range(Cells(2, 1), Cells(iRows,
1)).ClearContents
Range("E1").Range(Cells(2, 1), Cells(iRows,
1)).ClearContents
If MsgBox("Encrypt and decrypt with formula?",
vbYesNo) = vbNo Then Exit Sub
Range("D1").Range(Cells(2, 1), Cells(iRows,
1)).Formula = "=Encrypt(B2,TRUE)"
Range("E1").Range(Cells(2, 1), Cells(iRows,
1)).Formula = "=Encrypt(D2,FALSE)"
End Sub
Sub Encrypting()
Dim sText As String, i As Long
Sheet3.Activate
Columns("D:E").ClearContents
MsgBox "Encrypting and decrypting column B"
For i = 2 To
Range("A1").CurrentRegion.Rows.Count
Cells(i, 4) = Encrypt(Cells(i, 2), True)
Cells(i, 5) = Encrypt(Cells(i, 4), False)
Cells.EntireColumn.AutoFit
Next i
End Sub
Chapter 89: Encrypting a
Spreadsheet
What the simulation does
Option Explicit
Dim bEncrypt As Boolean
Sub Processing()
If bEncrypt = False Then
bEncrypt = True: Encrypting
Else
bEncrypt = False: Encrypting
End If
End Sub
Sub Encrypting()
Dim oWS1 As Worksheet, oWS2 As Worksheet,
oCell As Range, oSelect As Range, sAddr As String
Set oWS1 = ActiveSheet
Set oSelect = Application.InputBox("Range", ,
Range("A1").CurrentRegion.Address, , , , , 8)
Set oWS2 = Sheets.Add(, oWS1)
For Each oCell In oSelect
sAddr = oCell.Address ; oWS2.Range(sAddr) =
Encrypt(oCell.Value, bEncrypt)
Next oCell
oWS2.Cells.EntireColumn.AutoFit
If MsgBox("Do you want an encrypted CSV file?",
vbYesNo) = vbYes Then SaveAsText
If bEncrypt = False Then Exit Sub
If MsgBox("Do you want to decrypt next?",
vbYesNo) = vbYes Then bEncrypt = False: Encrypting
End Sub
Sub SaveAsText()
Dim vExe As Variant, oSelect As Range
Set oSelect = Application.InputBox("Range", ,
Range("A1").CurrentRegion.Address, , , , , 8)
oSelect.Copy : vExe = Shell("notepad.exe",
vbNormalFocus)
AppActivate vExe ; SendKeys "^V", True
End Sub
Chapter 90: Numbering Records
What the simulation does
Option Explicit
Sub Numbering()
Dim oRange As Range
Range("A1").EntireColumn.Insert
Range("A1") = "ID"
Set oRange = Range("A1").CurrentRegion
Set oRange = oRange.Offset(1,
0).Resize(oRange.Rows.Count - 1, 1)
With oRange
MsgBox "Consecutive numbering."
.Formula = "=ROW(A1)"
.Formula = .Value
MsgBox "With leading zeros."
.Formula = "=RIGHT(""000"" & ROW(A1),3)"
.Copy: .PasteSpecial
xlPasteValuesAndNumberFormats
Application.CutCopyMode = False:
Range("A1").Select
MsgBox "Starting at 1001."
.Formula = "=ROW(A1001)"
.Formula = .Value: Application.CutCopyMode =
False
MsgBox "Repeating from 1 to 5."
.Formula = "=MOD(ROW(A1)-1,5)+1"
.Formula = .Value
MsgBox "Repeating each number 5 times."
.Formula = "=QUOTIENT(ROW(A1)-1,5)+1"
.Formula = .Value
End With
MsgBox "The last step deletes column A"
Range("A1").EntireColumn.Delete
Do While MsgBox("In H11:K16, we sort data
randomly. Again?", vbYesNo) = vbYes
Calculate
Loop
End Sub
Chapter 91: Sizing Bins for
Frequencies
What you need to know
Option Explicit
Sub BinSizing()
Dim iBin As Integer, oData As Range, oBins As
Range, oFreqs As Range
On Error Resume Next
Sheet1.Names("data").Delete
Set oData = Application.InputBox("Range", ,
Range("A1").CurrentRegion.Address, , , , , 8)
oData.Name = "data"
iBin = InputBox("How many bins (5-10...-30)?", ,
20)
If iBin > 30 Then Exit Sub
Columns("G:H").ClearContents
Set oBins = Range(Cells(1, 7), Cells(iBin, 7))
oBins.Formula = "=INT(MIN(data)+(ROW(A1)*
(MAX(data)-MIN(data))/" & iBin & "))"
Set oFreqs = Range(Cells(1, 8), Cells(iBin + 1, 8))
'+1 for the left-overs
oFreqs.FormulaArray = "=FREQUENCY(data," &
oBins.Address & ")"
oData.Select
End Sub
Chapter 92: Creating Calendars
What the simulation does
This macro creates a calendar for the month and year of your
choosing, either in a MsgBox (picture above) or on the sheet itself (picture
below)
What you need to know
Sub Calendar()
Dim dStart As Date, dDay As Date
Dim i As Integer, sCal As String
dStart = InputBox("Start", , Date)
For i = 0 To 30
dDay = dStart + i
If Weekday(dDay) <> 1 And Weekday(dDay) <>
7 Then
sCal = sCal & vbCr & Format(dDay, "ddd" &
vbTab & "mm/dd/yy")
Else
sCal = sCal & vbCr
End If
Next i
MsgBox sCal
End Sub
Sub MonthDisplay()
Dim dDate As Date, sCal As String, i As Integer,
iMonth As Integer, iYear As Integer
iMonth = InputBox("Month", , Month(Now()))
iYear = InputBox("Year", , Year(Now()))
sCal = MonthName(iMonth) & " " & iYear &
vbCr
sCal = sCal & "S" & vbTab & "M" & vbTab &
"T" & vbTab & "W" & vbTab & "T" & vbTab & "F"
& vbTab & "S" & vbCr
dDate = DateSerial(iYear, iMonth, 1 : dDate =
dDate - Weekday(dDate) + 1
Do
For i = 1 To 7
If Month(dDate) = iMonth Then sCal = sCal
& Day(dDate)
sCal = sCal & vbTab
dDate = dDate + 1
Next i
sCal = sCal & vbCr
Loop While Month(dDate) = iMonth
MsgBox sCal
End Sub
Sub SheetCalendar()
Dim dDate As Date, iMonth As Integer, iYear As
Integer
Dim sRange As String, r As Integer, i As Integer
sRange = Application.InputBox("Start in cell", ,
"A1")
iMonth = InputBox("Month", , Month(Now()))
iYear = InputBox("Year", , Year(Now()))
With Range(sRange)
.Value = MonthName(iMonth) & " " & iYear
.Range(Cells(1, 1), Cells(1, 7)).Merge
.HorizontalAlignment = xlCenter
r= 2
For i = 1 To 7
.Cells(r, i) = Left(WeekdayName(i), 3)
Next i
dDate = DateSerial(iYear, iMonth, 1)
dDate = dDate - Weekday(dDate) + 1
Do
r= r+ 1
For i = 1 To 7
If Month(dDate) = iMonth Then .Cells(r, i)
= Day(dDate) Else .Cells(r, i) = ""
dDate = dDate + 1
Next i
Loop While Month(dDate) = iMonth
.CurrentRegion.BorderAround , xlThick
End With
End Sub
Chapter 93: Populating a Jagged
Array
What the simulation does
Option Explicit
Sub JaggedArray()
Dim arrMain(25) As Variant, arrSub() As String
Dim i As Integer, j As Integer, iRand As Integer
Dim cSubTotal As Currency, cGrandTotal As
Currency
Range("A1").CurrentRegion.Cells.Interior.ColorIndex
=0
Range("A1").CurrentRegion.ClearContents
'Loop thru Main Array and create Sub arrays of
random length
For i = 0 To UBound(arrMain)
iRand = Int(Rnd() * 15)
ReDim arrSub(iRand)
For j = 0 To UBound(arrSub)
arrSub(j) = FormatCurrency(Rnd() * 1000)
Next j
arrMain(i) = arrSub
Next i
'Call InsertSheet below if you like
For i = 0 To UBound(arrMain)
For j = 0 To UBound(arrMain(i))
ActiveCell.Offset(i, j) = arrMain(i)(j)
cSubTotal = cSubTotal + arrMain(i)(j)
Next j
ActiveCell.Offset(i, j) = cSubTotal
cGrandTotal = cGrandTotal + cSubTotal:
cSubTotal = 0
ActiveCell.Offset(i, j).Interior.ColorIndex = 15
Next i
ActiveCell.Offset(i, j) = cGrandTotal
ActiveCell.Offset(i, j - 1) = "GrandTotal"
Cells.EntireColumn.AutoFit
End Sub
Sub InsertSheet()
Dim oWS As Worksheet, sName As String
Again:
sName = InputBox("Which name?")
If sName = "" Then Exit Sub
For Each oWS In Worksheets
If LCase(oWS.Name) = LCase(sName) Then
GoTo Again
Next oWS
Set oWS = Worksheets.Add(, ActiveSheet)
oWS.Name = sName
End Sub
Chapter 94: Filtering a Database
What the simulation does
Option Explicit
Sub FilterDB()
Dim oData As Range, oFilter As Range, i As
Integer, sSet As String, oWS As Worksheet
Set oData = ActiveCell.CurrentRegion
oData.Rows(1).Copy
Set oWS = Worksheets.Add(, ActiveSheet)
ActiveCell.PasteSpecial
For i = 1 To oData.Columns.Count
sSet = InputBox("Set filter (or leave empty) " &
oData.Cells(1, i))
If sSet <> "" Then ActiveCell.Offset(1, i - 1) =
sSet
Next i
Set oFilter = ActiveCell.CurrentRegion
oData.AdvancedFilter xlFilterCopy,
Range(oFilter.Address), Range("A4")
oFilter.EntireColumn.AutoFit
End Sub
Sub HideRows()
Dim col As Integer, r As Long, i As Long, iCount
As Long, oSelect As Range
With ActiveCell.CurrentRegion
r = .Rows.Count
Set oSelect = Application.InputBox("Select a
value to filter for", , Range("G4").Address, , , , , 8)
oSelect.Select: col = ActiveCell.Column
For i = 2 To r
If .Cells(i, col) <> ActiveCell Then
.Cells(i, col).EntireRow.Hidden = True
Else
iCount = iCount + 1
End If
Next i
MsgBox iCount & " records"
If MsgBox("Unhide rows?", vbYesNo) = vbYes
Then .EntireRow.Hidden = False
End With
End Sub
Chapter 95: Formatting Phone
Numbers
What the simulation does
Option Explicit
The “trick” to achieve this is using the AVERAGE function, but in such
a way that the formula refers to two neighboring cells plus itself—for
instance, in cell B8: =AVERAGE(A8:C8). Since the formula in such cells
uses a reference to itself, it causes circular reference. Excel does not allow
this, unless you temporarily turn Iteration on.
Once the formulas are “settled,” the macro replaces them with the
values found, so it can turn Iteration back off.
If the matrix would have more cells, you may have to increase
MaxIterations in the VBA code, to make sure each cells reaches a stable
value.
What you need to do
Option Explicit
Sub Gradients()
Application.Iteration = True
Application.MaxIterations = 1000
Application.Calculation = xlCalculationAutomatic
Do
Range("A8") = Rnd: Range("A8").Formula =
Range("A8").Value
Range("E8") = Rnd: Range("E8").Formula =
Range("E8").Value
Range("A12") = Rnd: Range("A12").Formula
= Range("A12").Value
Range("E12") = Rnd: Range("E12").Formula
= Range("E12").Value
'Fill the outer ranges first and then the center
Range("B8:D8").Formula =
"=AVERAGE(A8:C8)"
Range("E9:E11").Formula =
"=AVERAGE(E8:E10)"
Range("B12:D12").Formula =
"=AVERAGE(A12:C12)"
Range("A9:A11").Formula =
"=AVERAGE(A8:A10)"
Range("B9:D11").Formula =
"=AVERAGE(A8:C10)"
'Replace formulas with values
Range("A8:E12").Formula =
Range("A8:E12").Value
Loop Until MsgBox("Repeat?", vbYesNo) = vbNo
Application.Iteration = False
End Sub
Chapter 97: Aligning Multiple
Charts
What the simulation does
Sub Types()
UserForm1.Show vbModeless ‘see code above
End Sub
Chapter 98: Temperature
Fluctuations
What the simulation does
Option Explicit
Sub Temps()
Dim oRange As Range, r As Long
'to protect the "hidden" columns
Sheet1.Unprotect
Columns("C:F").Cells.Font.Color = vbWhite
Sheet1.Protect , False, , , True 'True allows VBA to
work
Set oRange = Range("A1").CurrentRegion
r = oRange.Rows.Count: r = r - 1
Set oRange = oRange.Offset(1, 0).Resize(r,
oRange.Columns.Count)
Do
oRange.Columns(3).Formula =
"=PERCENTILE($B$2:$B$66,$C$1)"
oRange.Columns(4).Formula =
"=PERCENTILE($B$2:$B$66,$D$1)"
oRange.Columns(5).Formula =
"=IF(B2>C2,B2,NA())"
oRange.Columns(6).Formula =
"=IF(B2<D2,B2,NA())"
Loop Until MsgBox("Repeat?", vbYesNo) = vbNo
If MsgBox("Protect the formulas in columns
A:E?", vbYesNo) = vbYes Then
Cells.Locked = False
Columns("A:F").Locked = True
Sheet1.Protect , , , , True, True
End If
End Sub
Chapter 99: Working with Fiscal
Years
What the simulation does
Excel has great functions to extract the year, month, and day part of a
date—but amazingly enough, it has no function to find out to which quarter
of the year such a date belongs. For data analysis and summary overviews,
that is quite a limitation. This problem can be solved, though, with a simple
formula of nested functions such as ROUNDUP(MONTH(any date)/3,0).
However, finding the correct quarter becomes much harder when your
company does not have a regular fiscal year. That’s where a macro comes in
handy. On this sheet, an InputBox inquires in which month your fiscal year
starts and stores that number in an internal variable (and in cell K2). Based
on that information, the macro calculates for any particular date to which
fiscal year and quarter that date belongs.
The sheet contains two macros: RegularYear for a regular year and
FiscalYear for a fiscal year. However, the 2nd macro can also handle a
regular year by calling the 1st macro, RegularYear, when needed.
What you need to know
The table to the right is only for comparison purposes so you can
check whether your calculations in the left table are correct. Conditional
formatting in the range M1:P24 does the rest:
=AND(ROW()>=$K$2,ROW()<$K$2+12)
What you need to do
Option Explicit
Sub RegularYear()
Dim i As Long, dDate As Date, pQtr As Double,
oStart As Range
Columns("D:E").ClearContents
Set oStart = Application.InputBox("Select the top
date", , Range("C2").Address, , , , , 8)
With oStart
Do While .Offset(i, 0) <> ""
dDate = .Offset(i, 0)
.Offset(i, 1) = Year(dDate)
pQtr = Month(dDate) / 3
.Offset(i, 2) = IIf(pQtr - Int(pQtr) = 0, pQtr,
Int(pQtr) + 1) 'Instead of RoundUp
i=i+1
Loop
End With
End Sub
Sub FiscalYear()
Dim i As Long, dDate As Date, iFiscMonth As
Integer, iMonth As Integer, oStart As Range
Columns("D:E").ClearContents
Set oStart = Application.InputBox("Select the top
date", , Range("C2").Address, , , , , 8)
iFiscMonth = InputBox("In which month does
your fiscal year start?", , 10)
Range("K2") = iFiscMonth
If iFiscMonth = 1 Then RegularYear: Exit Sub
With oStart
Do While .Offset(i, 0) <> ""
dDate = .Offset(i, 0)
.Offset(i, 1) = Year(dDate) + IIf(Month(dDate)
>= iFiscMonth, 1, 0)
iMonth = Month(.Offset(i, 0)) - iFiscMonth +
1
If iMonth <= 0 Then iMonth = iMonth + 12
.Offset(i, 2) = IIf(iMonth / 3 - Int(iMonth / 3)
= 0, iMonth / 3, Int(iMonth / 3) + 1)
i=i+1
Loop
End With
End Sub
Chapter 100: Time Calculations
What the simulation does
This is basically all the macro does for summaries below the table, if
needed,and also to the right, if so desired. On the next run it will delete
those summaries first.
Some people prefer to use hours with decimals—where, for example,
13.50 (with a decimal point) is 13 hours and 30 minutes, as opposed to
13:50 (with a colon), which is 13 hours and 50 minutes. To convert these
decimals to Excel's time decimals, you need to divide by 24 because Excel
works with day units of 24 hours, 60 minutes, and 60 seconds.
What you need to do
Option Explicit
Sub TimeCalc()
Dim oSum As Range, oTable As Range, oAvg As
Range, r As Long, c As Long
Set oTable = Range("B2").CurrentRegion
r = oTable.Rows.Count: c = oTable.Columns.Count
oTable.Rows(r).Offset(2, 0).ClearContents
oTable.Rows(r).Offset(3, 0).ClearContents
oTable.Columns(c).Offset(0, 2).ClearContents
oTable.Columns(c).Offset(0, 3).ClearContents
If MsgBox("Summaries at the bottom?", vbYesNo)
= vbYes Then
Cells(r + 2, 1) = "Sum"
Set oSum = Range(Cells(r + 2, 2), Cells(r + 2, c))
Cells(r + 3, 1) = "Mean"
Set oAvg = Range(Cells(r + 3, 2), Cells(r + 3, c))
oSum.FormulaR1C1 = "=SUM(R[-" & r &
"]C:R[-2]C)"
oSum.NumberFormat = "[h]:mm:ss"
oAvg.FormulaR1C1 = "=AVERAGE(R[-" & r +
1 & "]C:R[-3]C)"
oAvg.NumberFormat = "h:mm:ss"
End If
If MsgBox("Also summaries to the right?",
vbYesNo) = vbYes Then
Cells(1, c + 2) = "Sum"
Set oSum = Range(Cells(2, c + 2), Cells(r, c +
2)): oSum.ClearContents
Cells(1, c + 3) = "Mean"
Set oAvg = Range(Cells(2, c + 3), Cells(r, c + 3)):
oAvg.ClearContents
oSum.FormulaR1C1 = "=SUM(RC[-" & r &
"]:RC[-2])"
oSum.NumberFormat = "[h]:mm:ss"
oAvg.FormulaR1C1 = "=AVERAGE((RC[-" & r
+ 1 & "]:RC[-3]))"
oAvg.NumberFormat = "h:mm:ss"
End If
End Sub
IX. APPENDIX
Data Tables
A Data Table is a range of cells that shows how changing one or two
variables in your formulas will affect the results of those formulas. A Data
Table provides a powerful way of calculating multiple results in one
operation and a way to view and compare the results of all the different
variations together on your worksheet.
To implement a Data Table, you select the entire range, including its
point of origin with a formula in it—so that is B3:F13 in the example above.
Then you go through the following menus: Data | What-If Analysis | Data
Table. In the dialog box, set the row input to cell B2 and the column input to
cell B1.
Once you click OK, Excel replaces all empty cells (in the shaded area)
with an array formula like this: {=TABLE(B2,B1)}. Or more in general,
{=TABLE(row-input-cell, column-input-cell)}. Sometimes, one or both of the
two arguments are missing. Do not type the braces—Excel creates them
automatically when you hit the Data Table button. And do not type the
formula!
Why use a Data Table? There are several reasons. First, it might be
easier to implement one than working with locked and unlocked cell
references. Second, no part of the array can inadvertently be deleted or
changed, because the array acts as one entire unit. Third, a Data Table has
much more extra potential, as you can see in many of the simulations we use
in this book.
However, there is one drawback. Because there may be many
operations involved in a Data Table, Excel may run into speed problems.
There are two ways to get around this speed issue. Method #1 is to stop
automatic recalculation—at least for Data Tables. Do the following: File |
Options | Options | Formulas | Automatic Except for Data Tables (you can
even set all calculations to manual). If you ever need to recalculate a Data
Table, just use Sh + F9, and that will recalculate only the particular sheet
you are on (whereas F9 alone would recalculate the entire file).
Method #2 is that, after you run a specific what-if analysis, you copy
the Data Table section—that is, the area between the top row and the left
column—and then paste it as values over itself. Move on to the next Data
Table, run it, and paste values again. Whenever you need to run a pasted table
again, quickly reimplement the Data Table.
One more limitation: A Data Table cannot accommodate more than two
variables. So they are at best two-dimensional but never three-dimensional.
There are ways to get around this limitation as shown in some simulations
(e.g. Chapter 69).
In VBA, it is actually very easy to implement a Data Table by using a
range’s Table method followed by a space and two arguments, one for the
row input and one for the column input.
Simulation Controls
Controls such as spin buttons and scroll bars are great tools for many
kinds of what-if analysis. They quickly reset specific hard-coded values and
then show you the impact of such operations.
In order to create such controls, you need the Developer tab in your
menu, which may not be present on your machine. To add it to the ribbon,
you do the following, depending on your Excel version. Pre-2010: File |
Options | General | Enable the Developer Tab. In 2010 and 2013: File |
Options | Customize Ribbon | in the far right list: Developer. From now on,
the tab can be found in the menu on top.
A
Activesheet 12
Active-X Controls 203
AdvancedFilter 132, 188
ampersand 14
Application.InputBox 98
Application.ScreenUpdating 68
Application.StatusBar 174
Application.Volatile 104
APR 156, 160
Areas 194
arrays 208
Asc 174
Asian option 172
AutoFit 16
average value option 172
B
bi-modal 32
BINOM.INV 42
BINOMDIST 40, 42
binomial distribution 28, 40
Boltzmann equation 114
Boolean 20
bootstrapping 50
BreakPoint 68
Brownian motion 62
Brusselator model 122
C
calendar 184
Cells 4
CHAR 18, 174
ChartObjects 24
Cholensky decomposition 54
Chr 174
chromosomes 80
circular reference 68, 192
CODE 174
ComboBox 194
CommandButton 32
compounding 156
CONFIDENCE 34
confidence interval 36, 114
controls 203
correlated distributions 54
COUNTA 164
COUNTIFS 66
CRITBINOM 42
CStr 14
CurrentRegion 6
CutCopyMode 74
D
Data Table 12, 202
dates 148
DateSerial 184
DAYS 148
degrees of freedom 36
Design Mode 203
Dim 8
DNA sequencing 96
DoEvents 8
Do-loop 8, 14
DSUM 132
E
EC50 determination 114
Ehrenfest Urn 64
encryption 176
EntireColumn 16
epidemic 112
Err 38
error handling 88, 209
evolutionary strategy 124
exchange rate 78
Exit Sub 4
EXP 172
exponential discounting 158
exponential smoothing 152
F
filter 132, 188
fiscal year 198
fitness 92
flocking behavior 22
For-Each-loop 34, 178
For-loop 4
FormatConditions 34
FormatCurrency 16
FormatNumber 10
Formula 40
FormulaR1C1 16, 207
FormulArray 24
founder effect 88
FREQUENCY 24, 182
G
Galton board 52
game theory 124
Gantt chart 148
GDP growth 140
genetic drift 88
GoalSeek 36
GoTo 2
gradients 192
H
Hardy-Weinberg law 86
HasFormula 154
heterozygote 84
HLOOKUP 106, 138
homozygote 84
I
IC50 determination 114
IF statements 204
IFERROR 42
iif function 3
INDEX 50
InputBox 12, 124
Application. 98
Int 14
INT 2
integration 100, 102
interpolation 116
Inter-Quartile Range 48
IPMT 160
ISERROR 42
ISFORMULA 70
Iteration 192
J
jagged array 186, 208
L
Len 190
LinkedCell 203
Locals Window 68
logistic equation 114
LOGNORM.INV 46
lognormal distribution 28, 46
Lotka-Volterra model 108
M
MATCH 116
matrix elimination 98
Median Absolute Deviation 48
medicine 110
Mendelian laws 84
Mid 190
MINVERSE 98
MMULT 54, 98
Mod 6
MOD 6
molecular clock 94
Monte Carlo simulation 60
moving averages 152
MsgBox 2
mutations 94
N
NA 66, 196
natural selection 90
net present value 158
normal distribution 24, 26
NORMDIST 26
NORMINV 26, 78
NotePad 178
Now 16
NPV 158
numbering 180
O
Offset 4, 134
On Error GoTo 38
Option Explicit 8
outliers 48
P
password 174
pendulum 118
percentile 128
PERCENTILE 128
phone number 190
PI function 104
PMT 160
population pyramid 106
PPMT 160
Preserve 78
project delay 148
Protect 134
Q
quality control 144
QUOTIENT 180
R
RAND 2
RANDBETWEEN 2
random sampling 56
random walk 62, 66
Range 4
Range Name 10, 182
ranges and cells 206
ReDim 78
REPT 112
Resize 134
return on investment 168
Rnd 2
ROI 168
ROW 38, 164
S
S&P500 performance 162
scenarios 138
Select Case 28, 190
SelectionChange 34
self-reference 68
SetSourceData 24
sex determination 82
Sheets.Count 40
sigmoidal equation 114
sinusoid 120
SIR model 112
SKEW 46
slope 114
Solver 114
solving equations 98
Sort 44
SQRT 36
standard deviation 36
standard error 36, 172
StrReverse 176
Student t-distribution 36
subtotals 154
Sum of Squared Residuals 114
T
Table 202
temperature 196
TEXT 46
time 200
time format 200
Timer 8
traffic 142
TRANSPOSE 54
TREND 116
U
UBound 32, 132
UserForm 194
UserInterfaceOnly 134
V
value type variables 205
Value-at-Risk 170
VaR 170
variable
global 8
Variant 4, 134
Variant arrays 68
VLOOKUP 18, 30, 74
W
waiting time 146
WeekDay 184
weighting 18, 44
Worksheet.Add 12
Worksheet_Change 116
About the Author
Variables as Arguments
Pivot Tables and Charts
www.Ebook777.com