'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''' ADVANCED EXCEL '''''''''''''''''''''
''''''''''' for scientific data analysis 2nd ed. '''''''''''
''''''''''''''''''''''' R. de Levie '''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''***************************************''''''''''
''''''''''* *''''''''''
''''''''''* SAMPLE FUNCTIONS & MACROS *''''''''''
''''''''''* *''''''''''
''''''''''***************************************''''''''''
''''''''''''''''''''''''''''''''''''''''''''(c) R. de Levie
'''''''''''''''''''''''''''''''''''''''''''' v 8, Aug. 2008
'
' The sample functions and macros listed here are those in
' chapters 1 through 11 of my book Advanced Excel for
' scientific data analysis, and are provided for the con-
' venience of those readers who prefer to download them
' rather than to type them in, a tedious and error-prone
' process. They are listed in the order in which they ap-
' pear in the text, and are identified by chapter and page
' number. For the sake of user convenience, some overlap
' with the MacroMorsels and MacroBundle is tolerated. In
' order to avoid possible confusion with routines of the
' same name, letters such as A, B, etc. have sometimes been
' added to the codes listed here. Wherever routines are il-
' lustrated in the text in separate sections, the preceding
' parts have been included in order to make the macros
' operable. Some of these routines, especially in the first
' few chapters, are not dimensioned, and therefore should
' NOT be used with Option Explicit.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Contents '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ch. 1 p. 37 Sub MovieDemo1A
' Ch. 1 p. 44Function Factorial
' Ch. 1 p. 48Function Lagrange
' Ch. 1 p. 58Function EE
' Ch. 1 p. 64Function Logarheads
' Ch. 4 p. 192 Sub BufferStrength
' Ch. 4 p. 214Function S
' Ch. 4 p. 217Function SA
' Ch. 6 p. 349Function Convol
' Ch. 7 p. 377Function siEulerA
' Ch. 7 p. 378Function siEulerB
' Ch. 7 p. 381Function siEulerBB
' Ch. 7 p. 383Function e4RKA
' Ch. 7 p. 385Function e4RKB
' Ch. 7 p. 390Function eEb
' Ch. 7 p. 393Function eRKb
' Ch. 7 p. 393Function eRKc
' Ch. 7 p. 395Function siEulerY
' Ch. 7 p. 395Function e4RKY
' Ch. 8 p. 404 Sub ReadA
' Ch. 8 p. 406 Sub ReadB
' Ch. 8 p. 407 Sub ReadC
' Ch. 8 p. 408 Sub ReadD
' Ch. 8 p. 408 Sub ReadRangeY
' Ch. 8 p. 409 Sub Cube1
' Ch. 8 p. 410 Sub Cube2
' Ch. 8 p. 411 Sub Root3
' Ch. 8 p. 412 Sub Root3A
' Ch. 8 p. 421 Sub ReadHighlightedCell
' Ch. 8 p. 422 Sub ReadHighlightedCellBlock1
' Ch. 8 p. 423 Sub ReadHighlightedCellBlock2
' Ch. 8 p. 423 Sub ReadBlockOfHighlightedCell
' Ch. 8 p. 425 Sub InputBoxForCellA
' Ch. 8 p. 426 Sub InputANumber
' Ch. 8 p. 426 Sub InputBoxForCellBlock
' Ch. 8 p. 429 Sub StudentT
' Ch. 8 p. 432 Sub InhibitScreenUpdatingA
' Ch. 8 p. 433 Sub KeepUserInformedA
' Ch. 8 p. 435 Sub Color
' Ch. 8 p. 436 Sub UseExcelFunction
' Ch. 8 p. 437 Sub UseExcelArrayFunction
' Ch. 8 p. 438 Sub DeconstructACellAddressA
' Ch. 8 p. 439 Sub DeconstructAnArrayAddressA
' Ch. 8 p. 441 Sub NumericalDifferentiation
' Ch. 8 p. 444 Sub AttachCellCommentsA
' Ch. 8 p. 446 Sub PropagationDemoA
' Ch. 8 p. 446 Sub PropagationDemoB
' Ch. 8 p. 449 Sub Fourier
' Ch. 8 p. 450 Sub Four1
' Ch. 8 p. 453 Sub ForwardFTA
' Ch. 8 p. 453 Sub InverseFTA
' Ch. 8 p. 453 Sub FourierA
' Ch. 8 p. 454 Sub FourierB
' Ch. 8 p. 457 Sub MakeGraph
' Ch. 8 p. 458 Sub MakeGraphA
' Ch. 8 p. 462 Sub InsertToolbarM
' Ch. 8 p. 463 Sub RemoveToolbarM
' Ch. 8 p. 468Function NatLog
' Ch. 8 p. 473 Sub TestImmediateWindow
' Ch. 11 p. 618Function cASINH
' Ch. 11 p. 619Function cErfA
' Ch. 11 p. 623 Sub TestDecimalAddition
' Ch. 11 p. 628 Sub Test1a
' Ch. 11 p. 629 Sub Test1b
' Ch. 11 p. 638 Sub Test3a
' Ch. 11 p. 638 Sub Test3b
' Ch. 11 p. 639 Sub Test4
' Ch. 11 p. 640Function TestSquareRoot
' Ch. 11 p. 640 Sub SquareRoot
' Ch. 11 p. 641 Sub ErrorAccumulation
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The functions and macros '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''' Chapter 1 page 37:
Sub MovieDemo1A()
' This sample will work only after the graph
' has been set up as described in the text
Range("A1") = 0
Range("A2") = 0
For i = 1 To 400
Range("A1") = 10 - 0.05 * Abs(i - 200)
Range("A2") = 10 * Exp(-0.001 * (i - 300) ^ 2)
Application.ScreenUpdating = True
Next i
Range("A1") = 0
Range("A2") = 0
End Sub
'''''''''''''''''''''''''''''''''''''''' Chapter 1 page 44:
Function Factorial(n)
'Illustration of a recursive function
If n <= 1 Then
Factorial = 1
Else
Factorial = n * Factorial(n – 1)
End If
End Function
'''''''''''''''''''''''''''''''''''''''' Chapter 1 page 48:
Function Lagrange(XArray, YArray, X, m)
' m denotes the order of the polynomial used,
' and must be an integer between 1 and 14
Dim Row As Integer, i As Integer, j As Integer
Dim Term As Double, Y As Double
Row = Application.Match(X, XArray, 1)
If Row < (m + 1) / 2 Then Row = (m + 1) / 2
If Row > XArray.Count - (m + 1) / 2 Then _
Row = XArray.Count - (m + 1) / 2
For i = Row - (m - 1) / 2 To Row + (m + 1) / 2
Term = 1
For j = Row - (m - 1) / 2 To Row + (m + 1) / 2
If i > j Then Term = Term * _
(X - XArray(j)) / (XArray(i) - XArray(j))
Next j
Y = Y + Term * YArray(i)
Next i
Lagrange = Y
End Function
'''''''''''''''''''''''''''''''''''''''' Chapter 1 page 58:
Function EE(x)
Dim m As Integer
Dim sum As Double
Dim oldterm As Double, newterm As Double
m = 1
sum = 1
oldterm = 1
Do
newterm = -(2 * m - 1) * oldterm / (2 * x * x)
sum = sum + newterm
oldterm = newterm
m = m + 1
Loop Until Abs(newterm) < 0.00000001
EE = sum / (x * Sqr([Pi()]))
End Function
'''''''''''''''''''''''''''''''''''''''' Chapter 1 page 64:
Function Logarheads(x)
MsgBox "Log(" & x & ") = " & Log(x) & " but" & Chr(13) & _
"Application.Log(" & x & ") = " & Application.Log(x)
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 4 page 193:
Sub BufferStrength()
' Computes the buffer strength B
' using first-order differencing.
' F is the proton function,
' H is the proton concentration, [H+].
Dim B As Double, Delta As Double
Dim vH As Double, vHm As Double, vHp As Double
Dim vF As Double, vFm As Double, vFp As Double
Dim rgH As Range, rgF As Range
Dim fA
Delta = 0.0000001
' Read F and H
Set rgF = Application.InputBox(Prompt:= _
"The proton function F is located in ", Type:=8)
rgF.Select
vF = rgF.Value
Set rgH = Application.InputBox(Prompt:= _
"The proton concentration is located in ", Type:=8)
rgH.Select
vH = rgHA.Value
fH = rgH.Formula
' Modify vH and read the corresponding values of vF
vHm = vH * (1 - Delta)
rgH.Select
Selection.Value = vHm
rgF.Select
vFm = rgF.Value
vHp = vH * (1 + Delta)
rgH.Select
Selection.Value = vHp
rgF.Select
vFp = rgF.Value
' Restore H
rgH.Select
Selection.Formula = fH
' Compute B = H*(dF/dH)
B = (vFp - vFm) / (2 * Delta)
' Write the result next to F
rgF.Select
Selection.Offset(0, 1).Select
Selection.Value = B
Selection.Offset(0, -1).Select
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 4 page 214:
Function S(x, amplitude, shift, a1, b1, c1, a2, b2, c2, _
a3, b3, c3, a4, b4, c4, a5, b5, c5, a6, b6, c6)
Dim T1 As Double, T2 As Double, T3 As Double
Dim T4 As Double, T5 As Double, T6 As Double
T1 = a1 / Exp(((x - c1 - shift) / b1) ^ 2)
T2 = a2 / Exp(((x – c2 - shift) / b2) ^ 2)
T3 = a3 / Exp(((x – c3 - shift) / b3) ^ 2)
T4 = a4 / Exp(((x – c4 - shift) / b4) ^ 2)
T5 = a5 / Exp(((x – c5 - shift) / b5) ^ 2)
T6 = a6 / Exp(((x – c6 - shift) / b6) ^ 2)
S = amplitude * (T1 + T2 + T3 + T4 + T5 + T6)
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 4 page 217:
Function SA(x, amplitude, shift, a1, b1, c1, a2, b2, c2, _
a3, b3, c3, a4, b4, c4, a5, b5, c5, a6, b6, c6)
Dim T1 As Double, T2 As Double, T3 As Double
Dim T4 As Double, T5 As Double, T6 As Double
If ((x - c1 - aa) / b1) < 25 Then _
T1 = a1 / Exp(((x - c1 - aa) / b1) ^ 2) Else T1 = 0
If ((x - c2 - aa) / b2) < 25 Then _
T2 = a2 / Exp(((x - c2 - aa) / b2) ^ 2) Else T2 = 0
If ((x - c3 - aa) / b3) < 25 Then _
T3 = a3 / Exp(((x - c3 - aa) / b3) ^ 2) Else T3 = 0
If ((x - c4 - aa) / b4) < 25 Then _
T4 = a4 / Exp(((x - c4 - aa) / b4) ^ 2) Else T4 = 0
If ((x - c5 - aa) / b5) < 25 Then _
T5 = a5 / Exp(((x - c5 - aa) / b5) ^ 2) Else T5 = 0
If ((x - c6 - aa) / b6) < 25 Then _
T6 = a6 / Exp(((x - c6 - aa) / b6) ^ 2) Else T6 = 0
SA = amplitude * (T1 + T2 + T3 + T4 + T5 + T6)
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 6 page 349:
Function Convol(Array1, Array2, Denom, N)
Dim i As Integer
Dim Sum As Double
Dim Array3 As Variant
ReDim Array3(1 To 2 * N)
For i = 1 To N
Array3(i) = Array2(N + 1 – i)
Next i
Sum = 0
For i = 1 To N
Sum = Sum + Array1(i – N + 1) * Array3(i)
Next i
Convol = Sum / Denom
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 377:
Function siEulerA(k1, oldT1, oldT2, n, oldA) As Double
'semi-implicit Euler method for A
Dim a As Double, f As Double, step As Double
Dim i As Integer
n = CInt(n)
a = oldA
step = (oldT2 - oldT1) / n
f = (1 - k1 * step / 2) / (1 + k1 * step / 2)
For i = 1 To n
a = a * f
Next i
siEulerA = a
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 378:
Function siEulerB _
(k1, k2, oldT1, oldT2, n, oldA, oldb) As Double
'semi-implicit Euler method for B
Dim a As Double, b As Double, step As Double
Dim f As Double, fA As Double, fB As Double
Dim i As Integer
n = CInt(n)
a = oldA
b = oldb
step = (oldT2 - oldT1) / n
f = (1 - k1 * step / 2) / (1 + k1 * step / 2)
fA = k1 * step / ((1 + k1 * step / 2) _
* (1 + k2 * step / 2))
fB = (1 - k2 * step / 2) / (1 + k2 * step / 2)
For i = 1 To n
b = a * fA + b * fB
a = a * f
Next i
siEulerB = b
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 381:
Function siEulerBB _
(k1, k2, oldT1, oldT2, n, crit, oldA, oldb) As Double
' Semi-implicit Euler method for B, modified so that
' it will switch automatically to the steady state
' approximation when k2/k1 becomes larger than a
' given value, here called crit (for criterion).
Dim a As Double, b As Double, step As Double
Dim f As Double, fA As Double, fB As Double
Dim i As Long, m As Long
n = CLng(n)
a = oldA
b = oldb
step = (oldT2 - oldT1) / n
f = (1 - k1 * step / 2) / (1 + k1 * step / 2)
If k2 / k1 > crit Then
For i = 1 To n
a = a * f
Next i
b = k1 * a / k2 ' The steady state approximation
End If
If (k2 / k1 > 1 And k2 / k1 <= crit) Then
m = CLng(Sqr(k2 / k1))
n = m * n
step = step / m
f = (1 - k1 * step / 2) / (1 + k1 * step / 2)
End If
If k2 / k1 <= crit Then
fA = k1 * step / ((1 + k1 * step / 2) _
* (1 + k2 * step / 2))
fB = (1 - k2 * step / 2) / (1 + k2 * step / 2)
For i = 1 To n
b = a * fA + b * fB
a = a * f
Next i
End If
siEulerBB = b
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 383:
Function e4RKA(k1, oldT1, oldT2, n, oldA) As Double
' Explicit fourth-order Runge-Kutta method for A
Dim a As Double, step As Double
Dim KA1 As Double, KA2 As Double
Dim KA3 As Double, KA4 As Double
Dim i As Integer
n = CInt(n)
a = oldA
step = (oldT2 - oldT1) / n
For i = 1 To n
KA1 = step * -k1 * a
KA2 = step * -k1 * (a + KA1 / 2)
KA3 = step * -k1 * (a + KA2 / 2)
KA4 = step * -k1 * (a + KA3)
a = a + (KA1 + 2 * KA2 + 2 * KA3 + KA4) / 6
Next i
e4RKA = a
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 385:
Function e4RKB(k1, k2, oldT1, oldT2, n, oldA, oldb) _
As Double
' Explicit fourth-order Runge-Kutta method for B
Dim a As Double, b As Double, step As Double
Dim KA1 As Double, KA2 As Double
Dim KA3 As Double, KA4 As Double
Dim KB1 As Double, KB2 As Double
Dim KB3 As Double, KB4 As Double
Dim i As Integer
n = CInt(n)
a = oldA
b = oldb
step = (oldT2 - oldT1) / n
For i = 1 To n
KA1 = step * -k1 * a
KA2 = step * -k1 * (a + KA1 / 2)
KA3 = step * -k1 * (a + KA2 / 2)
KA4 = step * -k1 * (a + KA3)
KB1 = step * (k1 * a - k2 * b)
KB2 = step * (k1 * (a + KA1 / 2) - k2 * (b + KB1 / 2))
KB3 = step * (k1 * (a + KA2 / 2) - k2 * (b + KB2 / 2))
KB4 = step * (k1 * (a + KA3) - k2 * (b + KB3))
b = b + (KB1 + 2 * KB2 + 2 * KB3 + KB4) / 6
a = a + (KA1 + 2 * KA2 + 2 * KA3 + KA4) / 6
Next i
e4RKB = b
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 390:
Function eEb(a, oldb, oldc, kk1, kk2, kk3, dt, n) _
As Double
Dim b As Double, c As Double
Dim i As Integer
b = oldb
c = oldc
For i = 1 To n
b = b + (kk1 * a * b - kk2 * b * c) * dt / n
c = c + (kk2 * b * c - kk3 * c) * dt / n
Next i
eEb = b
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 390:
Function eEc(a, oldb, oldc, kk1, kk2, kk3, dt, n) _
As Double
Dim b As Double, c As Double
Dim i As Integer
b = oldb
c = oldc
For i = 1 To n
b = b + (kk1 * a * b - kk2 * b * c) * dt / n
c = c + (kk2 * b * c - kk3 * c) * dt / n
Next i
eEc = c
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 393:
Function eRKb(a, kk1, kk2, kk3, oldb, oldc, dt, n) _
As Double
Dim b As Double, c As Double, step As Double
Dim KB1 As Double, KB2 As Double
Dim KB3 As Double, KB4 As Double
Dim KC1 As Double, KC2 As Double
Dim KC3 As Double, KC4 As Double
Dim i As Integer
step = dt / n
b = oldb
c = oldc
For i = 1 To n
KB1 = step * (kk1 * a * b - kk2 * b * c)
KB2 = step * (kk1 * a * (b + KB1 / 2) _
- kk2 * (b + KB1 / 2) * (c + KC1 / 2))
KB3 = step * (kk1 * a * (b + KB2 / 2) _
- kk2 * (b + KB2 / 2) * (c + KC2 / 2))
KB4 = step * (kk1 * a * (b + KB3) _
- kk2 * (b + KB3) * (c + KC3))
KC1 = step * (kk2 * b * c - kk3 * c)
KC2 = step * (kk2 * (b + KB1 / 2) * (c + KC1 / 2) _
- kk3 * (c + KC1 / 2))
KC3 = step * (kk2 * (b + KB2 / 2) * (c + KC2 / 2) _
- kk3 * (c + KC2 / 2))
KC4 = step * (kk2 * (b + KB3) * (c + KC3) _
- kk3 * (c + KC3))
b = b + (KB1 + 2 * KB2 + 2 * KB3 + KB4) / 6
c = c + (KC1 + 2 * KC2 + 2 * KC3 + KC4) / 6
Next i
eRKb = b
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 393:
Function eRKc(a, kk1, kk2, kk3, oldb, oldc, dt, n) _
As Double
Dim b As Double, c As Double, step As Double
Dim KB1 As Double, KB2 As Double
Dim KB3 As Double, KB4 As Double
Dim KC1 As Double, KC2 As Double
Dim KC3 As Double, KC4 As Double
Dim i As Integer
step = dt / n
b = oldb
c = oldc
For i = 1 To n
KB1 = step * (kk1 * a * b - kk2 * b * c)
KB2 = step * (kk1 * a * (b + KB1 / 2) _
- kk2 * (b + KB1 / 2) * (c + KC1 / 2))
KB3 = step * (kk1 * a * (b + KB2 / 2) _
- kk2 * (b + KB2 / 2) * (c + KC2 / 2))
KB4 = step * (kk1 * a * (b + KB3) _
- kk2 * (b + KB3) * (c + KC3))
KC1 = step * (kk2 * b * c - kk3 * c)
KC2 = step * (kk2 * (b + KB1 / 2) * (c + KC1 / 2) _
- kk3 * (c + KC1 / 2))
KC3 = step * (kk2 * (b + KB2 / 2) * (c + KC2 / 2) _
- kk3 * (c + KC2 / 2))
KC4 = step * (kk2 * (b + KB3) * (c + KC3) _
- kk3 * (c + KC3))
b = b + (KB1 + 2 * KB2 + 2 * KB3 + KB4) / 6
c = c + (KC1 + 2 * KC2 + 2 * KC3 + KC4) / 6
Next i
eRKc = c
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 395:
Function siEulerY(oldX1, oldX2, n, oldY) As Double
' Semi-implicit Euler method for exercise 7.9
Dim Y As Double, step As Double
Dim i As Integer
n = CInt(n)
Y = oldY
step = (oldX2 - oldX1) / n
For i = 1 To n
Y = Y + (Y * Y + 1) / ((1 / step) - Y)
Next i
siEulerY = Y
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 7 page 395:
Function e4RKY(oldX1, oldX2, n, oldY)
'explicit 4th order Runge-Kutta for exercise 7.9
Dim X As Double, Y As Double, step As Double
Dim k1 As Double, k2 As Double
Dim k3 As Double, k4 As Double
Dim i As Integer
X = oldX1
Y = oldY
n = CInt(n)
step = (oldX2 - oldX1) / n
For i = 1 To n
k1 = step * (Y ^ 2 + 1)
k2 = step * (((Y + k1 / 2) ^ 2) + 1)
k3 = step * (((Y + k2 / 2) ^ 2) + 1)
k4 = step * (((Y + k3) ^ 2) + 1)
Y = Y + (k1 + 2 * k2 + 2 * k3 + k4) / 6
X = X + step
Next i
e4RKY = Y
End Function
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 404:
Sub ReadA()
'Read the cell value
CellValue = Selection.Value
MsgBox "The cell value is " & CellValue
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 406:
Sub ReadB()
'Read & change the cell value
cellValue = Selection.Value
MsgBox "The cell value is " & cellValue
cellValue = cellValue * 7
Selection.Value = cellValue
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 407:
Sub ReadC()
'Read & change the cell value
cellValue = Selection.Value
'MsgBox "The cell value is " & cellValue
cellValue = cellValue * 7
Selection.Offset(1, 0).Select
Selection.Value = cellValue
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 408:
Sub ReadD()
'Read the cell address, formula, and value
cellAddress = Selection.Address
MsgBox "The cell address is " & cellAddress
cellFormula = Selection.Formula
MsgBox "The cell formula is " & cellFormula
cellValue = Selection.Value
'MsgBox "The cell value is " & cellValue
cellValue = cellValue * 7
Selection.Offset(1, 0).Select
Selection.Value = cellValue
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 408:
Sub ReadRangeY()
aY = Selection.Address
MsgBox "The range address is " & aY
vY = Selection.Value
MsgBox "The value of cell (1,1) is " & vY(1,1)
MsgBox "The value of cell (5,2) is " & vY(5,2)
fY = Selection.Formula
MsgBox "The formula in cell (1,1) is " & fY(1,1)
MsgBox "The formula in cell (5,2) is " & fY(5,2)
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 409:
Sub Cube1()
For Each cell In Selection.Cells
cell.Value = cell.Value ^ 3
Next cell
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 410:
Sub Cube2()
Dim Array2 As Variant
Dim c As Integer, cMax As Integer
Dim r As Integer, rMax As Integer
Array2 = Selection.Value
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
For r = 1 To rMax
For c = 1 To cMax
Array2(r, c) = Array2(r, c) ^ 3
Next c
Next r
Selection.Value = Array2
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 411:
Sub Root3()
'Take the cube root of all array elements
Dim Array3 As Variant
Dim c As Integer, cMax As Integer
Dim r As Integer, rMax As Integer
Array3 = Selection.Value
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
For r = 1 To rMax
For c = 1 To cMax
Array3(r, c) = Array3(r, c) ^ (1 / 3)
Next c
Next r
Selection.Value = Array3
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 412:
Sub Root3A()
'Take the cube root ofall array elements
Dim Array3 As Variant
Dim c As Integer, cMax As Integer
Dim r As Integer, rMax As Integer
Dim p As Double
p = 1 / 3
Array3 = Selection.Value
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
For r = 1 To rMax
For c = 1 To cMax
Array3(r, c) = Array3(r, c) ^ p
Next c
Next r
Selection.Value = Array3
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 421:
Sub ReadHighlightedCell()
Dim aX, fX, vX
aX = ActiveCell.Address
fX = ActiveCell.Formula
vX = ActiveCell.Value
Debug.Print "Address: " & aX
Debug.Print "Formula: " & fX
Debug.Print "Value: " & vX
Debug.Print ""
ActiveCell.Offset(1, 0).Select
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 422:
Sub ReadHighlightedCellBlock1()
Dim c As Long, cMax As Long
Dim r As Long, rMax As Long
Dim aA, fA, vA
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
If cMax = 1 And rMax = 1 Then
MsgBox "The block must contain more than one cell"
End
End If
ReDim fA(1 To rMax, 1 To cMax)
ReDim vA(1 To rMax, 1 To cMax)
aA = Selection.Address
fA = Selection.Formula
vA = Selection.Value
Debug.Print "Range Address: " & aA
For c = 1 To cMax
For r = 1 To rMax
Debug.Print "Formula(" & r & "," & c & "): " & fA(r, c)
Debug.Print "Value(" & r & "," & c & "): " & vA(r, c)
Next r
Next c
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 423:
Sub ReadHighlightedCellBlock2()
Dim c As Long, cMax As Long
Dim r As Long, rMax As Long
Dim aA, fA, vA, fX, vX
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
aA = Selection.Address
Debug.Print "Range Address: " & aA
If cMax = 1 And rMax = 1 Then ' for single cell input
fX = Selection.Formula
vX = Selection.Value
Debug.Print "Formula: " & fX
Debug.Print "Value: " & vX
ElseIf cMax > 1 Or rMax > 1 Then ' for multi-cell input
ReDim fA(1 To rMax, 1 To cMax)
ReDim vA(1 To rMax, 1 To cMax)
fA = Selection.Formula
vA = Selection.Value
For c = 1 To cMax
For r = 1 To rMax
Debug.Print "Formula(" & r & "," & c & "): " & _
fA(r, c)
Debug.Print "Value(" & r & "," & c & "): " & _
vA(r, c)
Next r
Next c
End If
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 423:
Sub ReadBlockOfHighlightedCell()
Dim c As Long, cMax As Long
Dim r As Long, rMax As Integer
Dim fX As String, vX As Double
Dim fA As Variant, vA As Variant
cMax = ActiveCell.CurrentRegion.Columns.Count
rMax = ActiveCell.CurrentRegion.Rows.Count
aA = ActiveCell.CurrentRegion.Address
Debug.Print "Address: " & aA
If cMax = 1 And rMax = 1 Then
fX = ActiveCell.Formula
vX = ActiveCell.Value
Debug.Print "Formula: " & fX
Debug.Print "Value: " & vX
Else If cMax > 1 Or rMax > 1 Then
ReDim fA(1 To rMax, 1 To cMax)
ReDim vA(1 To rMax, 1 To cMax)
fA = ActiveCell.CurrentRegion.Formula
vA = ActiveCell.CurrentRegion.Value
For c = 1 To cMax
For r = 1 To rMax
Debug.Print "Formula(" & r & "," & c & "): " & _
fA(r, c)
Debug.Print "Value(" & r & "," & c & "): " & _
vA(r, c)
Next r
Next c
End If
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 425:
Sub InputBoxForCellA()
Dim rgX As Range
Set rgX = Application.InputBox(Prompt:="InputCell: ", _
Type:=8)
rgX.Select
Debug.Print "Cell address: " & rgX.Address
Debug.Print "Cell formula: " & rgX.Formula
Debug.Print "Cell value: " & rgX.Value
Debug.Print ""
ActiveCell.Offset(1, 0).Select
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 426:
Sub InputANumber()
Tries = 0
MaxTries = 5
Message = "Enter an integer" & _
Chr(13) & "between 1 and 100:"
Title = "Integer"
Default = "25"
Do
myValue = InputBox(Message, Title, Default)
Tries = Tries + 1
If Tries > MaxTries Then End
If myValue < 1 Then MsgBox _
"The selected number is too small."
If myValue > 100 Then MsgBox _
"The selected number is larger than 100."
If myValue - Int(myValue) > 0 Then MsgBox _
"The selected number is not an integer."
Loop Until (myValue >= 0 And myValue <= 100 _
And myValue - Int(myValue) = 0)
MsgBox "You chose the number " & myValue
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 426:
Sub InputBoxForCellBlock()
Dim c As Long, cMax As Long
Dim r As Long, rMax As Integer
Dim rgA As Range
Dim vA As Variant
Set rgA = Application.InputBox(Prompt:="InputArray: ", _
Type:=8)
rgA.Select
cMax = rgA.Columns.Count
rMax = rgA.Rows.Count
ReDim vA(1 To rMax, 1 To cMax)
vA = Selection.Value
On Error Resume Next ' for single-cell input
For c = 1 To cMax
For r = 1 To rMax
Debug.Print r, c, rgA.Formula(r, c), rgA.Value(r, c)
Next r
Next c
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 429:
Sub StudentT()
Dim c As Integer, cMax As Integer
Dim r As Integer, rMax As Integer
cMax = 4: rMax = 20
ReDim t(1 To rMax, 1 To cMax) As Double
Dim a(1 To 4) As Double, rgA As Range
a(1) = 0.03: a(2) = 0.01: a(3) = 0.003: a(4) = 0.001
' Compute the table of Student t values
For r = 1 To rMax
For c = 1 To cMax
t(r, c) = Application.TInv(a(c), r)
Next c
Next r
' Write the array onto the spreadsheet
Set rgA = ActiveCell.Range(Cells(1, 1), Cells(rMax, cMax))
rgA.Value = t
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 432:
Sub InhibitScreenUpdatingA()
Dim Time1, Time2, Time3, Time4
Dim i As Integer, j As Integer
Time1 = Timer
For i = 1 To 5000
j = i
Selection.Value = j
Next i
Time2 = Timer
Debug.Print "ScreenUpdate On: " & _
Time2 - Time1 & " seconds"
Selection.Offset(1, 0).Select
Application.ScreenUpdating = False
Time3 = Timer
For i = 1 To 5000
j = i
Selection.Value = j
Next i
Time4 = Timer
Debug.Print "ScreenUpdate Off: " _
& Time4 – Time3 & " seconds"
Selection.Offset(-1, 0).Select
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 433:
Sub KeepUserInformedA()
Dim i As Long, j As Double
Application.StatusBar = True 'turn StatusBar on
Application.StatusBar = "The process is 0 % complete."
For i = 1 To 40000000
j = i
If Int(j / 2000000) = j / 2000000 Then _
Application.StatusBar = "The process is " _
& j / 400000 & " % complete." 'here: in 5% steps
Next i
MsgBox "You just counted to " & j
Application.StatusBar = False 'clean up
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 435:
Sub Color()
Dim colorValue As Integer
colorValue = Selection.Value
Selection.Interior.ColorIndex = colorValue
Selection.Offset(1, 0).Select
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 436:
Sub UseExcelFunction()
Dim a As Double, b As Double, vX As Double
vX = Selection.Value
a = Application.Log(vX) ' the Excel function log is the
' 10-based, Briggsian form,
b = Log(vX) ' while the VBA function log is the
' e-based, natural logarithm, in
' science typically denoted as ln
Debug.Print "Excel log(" & vX & ") = " & a & Chr(10) & _
" VBA log(" & vX & ") = " & b
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 437:
Sub UseExcelArrayFunction()
Dim c As Long, cMax As Long
Dim r As Long, rMax As Long
Dim vX As Variant, vY As Variant, vZ As Variant
' Check that the matrix is square
cMax = Selection.Columns.Count
rMax = Selection.Rows.Count
If cMax > rMax Then
MsgBox "Array must be square."
End
End If
' Read the array values in the highlighted range
vX = Selection.Value
' Move the highlighted range
Selection.Offset(rMax + 1, 0).Select
' Invert the matrix
vY = Application.MInverse(vX)
' Write the inverse matrix back onto the spreadsheet
Selection.Value = vY
' Once more move the highlighted range
Selection.Offset(rMax + 1, 0).Select
' Multiply the matrices
vZ = Application.MMult(vX, vY)
' Write the result back onto the spreadsheet.
Selection.Value = vZ
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 438:
Sub DeconstructACellAddressA()
Dim aC, cC, rC, Pos$2, CLeft
aC = Selection.Address
Pos$2 = InStr(2, aC, "$") 'yields position of 2nd $ in C
CLeft = Left(aC, Pos$2 - 1) 'yields string left of Pos$2
cC = Mid(CLeft, 2) 'yields the column name
rC = Mid(aC, Pos$2 + 1) 'yields the row number
Debug.Print "Address = " & aC
Debug.Print "Column Name = " & cC & ", Row Number = " & rC
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 439:
Sub DeconstructAnArrayAddressA()
Dim aA, aAbr, aAtl, cAbr, cAtl, rAbr, rAtl
Dim AColon, ADollar, A$
aA = Selection.Address
AColon = InStr(1, aA, ":") 'yields the colon position
aAtl = Left(aA, AColon - 1) 'yields top left address
aAbr = Mid(aA, Acolon + 1) 'yields bottom right address
A$ = InStr(2, aAtl, "$")
ADollar = Left(aAtl, A$ - 1)
cAtl = Mid(ADollar, 2)
rAtl = Mid(aAtl, A$ + 1)
A$ = InStr(2, aAbr, "$")
ADollar = Left(aAbr, A$ - 1)
cAbr = Mid(ADollar, 2)
rAbr = Mid(aAbr, A$ + 1)
Debug.Print "ArrayAddress: " & aA
Debug.Print "TopLeft: Cell Address = " & aAtl
Debug.Print " Column Name = " & cAtl
Debug.Print " Row Number = " & rAtl
Debug.Print "BottomRight: Cell Address = " & aAbr
Debug.Print " Column Name = " & cAbr
Debug.Print " Row Number = " & rAbr
End Sub
''''''''''''''''''''''''''''''''''''''' Chapter 8 page 441:
Sub NumericalDifferentiation()
Dim A As Double, Amin As Double, Aplus As Double
Dim F As Double, Fmin As Double, Fplus As Double
Dim Fderiv As Double
Dim rgA As Range, rgF As Range
' Read the values of A and F
Set rgF = Application.InputBox(Prompt:= _
"The function is located in ", Type:=8)
rgF.Select
F = rgF.Value
Set rgA = Application.InputBox(Prompt:= _
"The variable a is located in ", Type:=8)
rgA.Select
A = rgA.Value
' Modify A to Aplus and read the corresponding Fplus
Aplus = A * (1 + 1 / 1048576)
Selection.Value = Aplus
rgF.Select
Fplus = rgF.Value
' Modify A to Aminus and read the corresponding Fminus
Aminus = A * (1 - 1 / 1048576)
rgA.Select
Selection.Value = Aminus
rgF.Select
Fminus = rgF.Value