Good afternoon,
I have a spreadsheet that I received with what appears to be a few VBA-coded macros already present. I am not proficient in VBA or coding so I would like to know (1) what the code will do when executed (i.e. - a "translation" for a VBA novice) and (2) how to get the code to execute. I have pasted it below. Any help is much appreciated. Thanks!
Option Explicit
Option Base 1
Function RateMatrix(cust_id, eventDate, rating)
Dim i As Long, j As Long, k As Long
Dim lastDate As Date, firstDate As Date, nObs As Long, nRatings As Integer
Dim nTransitions() As Double, nYears() As Double, transitionRate() As Double, _
days_k As Double, sumOffDiag As Double
nRatings = Application.WorksheetFunction.Max(rating)
ReDim nTransitions(1 To nRatings, 1 To nRatings)
ReDim nYears(1 To nRatings)
ReDim transitionRate(1 To nRatings, 1 To nRatings)
nObs = Application.WorksheetFunction.Count(cust_id)
firstDate = Application.WorksheetFunction.Min(eventDate)
lastDate = Application.WorksheetFunction.Max(eventDate)
' Find numbers of transitions and times (years) in states.
For k = 1 To nObs - 1
If cust_id(k) = cust_id(k + 1) Then
days_k = (eventDate(k + 1) - eventDate(k))
nTransitions(rating(k), rating(k + 1)) = nTransitions(rating(k), rating(k + 1)) + 1
Else
days_k = (lastDate - eventDate(k))
End If
nYears(rating(k)) = nYears(rating(k)) + days_k / 365
Next k
'Last observation
nYears(rating(nObs)) = nYears(rating(nObs)) + (lastDate - eventDate(nObs)) / 365
For i = 1 To nRatings
sumOffDiag = 0
If nYears(i) > 0 Then
For j = 1 To nRatings
transitionRate(i, j) = nTransitions(i, j) / nYears(i)
If i <> j Then sumOffDiag = sumOffDiag + transitionRate(i, j)
Next j
End If
transitionRate(i, i) = -sumOffDiag
Next i
RateMatrix = transitionRate
End Function
Function MatrixAdd(ByVal array1, ByVal array2)
' This adds two matrices. Normally, there should be a check on whether they
' have the same dimensions, but this is assured for this program.
Dim i As Integer, j As Integer, nRows As Integer, nCols As Integer, sum
nRows = UBound(array1, 1)
nCols = UBound(array1, 2)
ReDim sum(1 To nRows, 1 To nCols)
For i = 1 To nRows
For j = 1 To nCols
sum(i, j) = array1(i, j) + array2(i, j)
Next j
Next i
MatrixAdd = sum
End Function
Function MatrixMult(ByVal array1, ByVal array2)
' If array1 is a number, multiply each element of array2 by this number.
' Otherwise, matrix multiply array1 by array2.
Dim i As Integer, j As Integer, nRows As Integer, nCols As Integer
Dim scalar As Single, product
If Application.WorksheetFunction.Count(array1) = 1 Then
scalar = array1
nRows = UBound(array2, 1)
nCols = UBound(array2, 2)
ReDim product(1 To nRows, 1 To nCols)
For i = 1 To nRows
For j = 1 To nCols
product(i, j) = scalar * array2(i, j)
Next j
Next i
MatrixMult = product
Else
MatrixMult = Application.WorksheetFunction.MMult(array1, array2)
End If
End Function
Function MatrixDiag(m As Integer, d As Double)
'Generate diagonal mxm matrix with entries d on diagional
Dim i As Integer, j As Integer, diagMat
ReDim diagMat(1 To m, 1 To m)
For i = 1 To m
For j = 1 To m
diagMat(i, j) = 0
Next j
diagMat(i, i) = d
Next i
MatrixDiag = diagMat
End Function
Function MatrixExp(Q, t As Single)
' For a given square matrix Q, this function calculates the matrix exp(Q * t)
' as the limit of a power series, that is, the sum of (Q^k)*(t^k)/Fact(k).
Dim error As Double, k As Long
Dim sum, Q_k, matrixAdded
'First entry (identity matrix)
sum = MatrixDiag(UBound(Q, 1), 1)
k = 1
error = 1
Do While (error > 10 ^ (-10) And k <= 170) 'Because fact(k) does not work for k>170
' Calculate the kth power of Q
If k = 1 Then
Q_k = Q
Else
Q_k = MatrixMult(Q_k, Q)
End If
' Multiply Q^k by t^k/Fact(k)
matrixAdded = MatrixMult(t ^ k / Application.WorksheetFunction.Fact(k), Q_k)
' Running sum (first k+1 terms of power series, including identity)
sum = MatrixAdd(matrixAdded, sum)
k = k + 1
' Eventually, the matrix added should be very close to 0
If k > 10 Then error = Application.WorksheetFunction.SumSq(matrixAdded)
Loop
MatrixExp = sum
End Function
Function TransProb(Q, t As Single)
' The function calculates the t-year transition probability matrix as exp(Q*t), where
' Q is the infinitesimal generator matrix. This is done by calculating the corresponding
' power series, the sum of (Q^k)*(t^k)/Fact(k). However, the negative diagonal values in Q
' can cause numerical roundoff problems, so Q is first made all nonnegative by adding
' the largest diagonal (in magnitude) to all diagonal elements. Then this addition is
' essentially undone in the last step of the procedure.
Dim n As Integer, maxDiag As Double
Dim i As Integer, array1, nonnegQ, tmp
array1 = Q
n = UBound(array1)
' Find maximal diagonal entry
maxDiag = 0
For i = 1 To n
If Abs(array1(i, i)) > maxDiag Then maxDiag = Abs(array1(i, i))
Next i
' Modify Q so that its diagonal entries are all nonnegative.
nonnegQ = MatrixAdd(MatrixDiag(n, maxDiag), array1)
' Find exp(nonnegQ * t)
tmp = MatrixExp(nonnegQ, t)
' Find exp(Q * t), the desired matrix.
TransProb = MatrixMult(Exp(-maxDiag * t), tmp)
End Function
I have a spreadsheet that I received with what appears to be a few VBA-coded macros already present. I am not proficient in VBA or coding so I would like to know (1) what the code will do when executed (i.e. - a "translation" for a VBA novice) and (2) how to get the code to execute. I have pasted it below. Any help is much appreciated. Thanks!
Option Explicit
Option Base 1
Function RateMatrix(cust_id, eventDate, rating)
Dim i As Long, j As Long, k As Long
Dim lastDate As Date, firstDate As Date, nObs As Long, nRatings As Integer
Dim nTransitions() As Double, nYears() As Double, transitionRate() As Double, _
days_k As Double, sumOffDiag As Double
nRatings = Application.WorksheetFunction.Max(rating)
ReDim nTransitions(1 To nRatings, 1 To nRatings)
ReDim nYears(1 To nRatings)
ReDim transitionRate(1 To nRatings, 1 To nRatings)
nObs = Application.WorksheetFunction.Count(cust_id)
firstDate = Application.WorksheetFunction.Min(eventDate)
lastDate = Application.WorksheetFunction.Max(eventDate)
' Find numbers of transitions and times (years) in states.
For k = 1 To nObs - 1
If cust_id(k) = cust_id(k + 1) Then
days_k = (eventDate(k + 1) - eventDate(k))
nTransitions(rating(k), rating(k + 1)) = nTransitions(rating(k), rating(k + 1)) + 1
Else
days_k = (lastDate - eventDate(k))
End If
nYears(rating(k)) = nYears(rating(k)) + days_k / 365
Next k
'Last observation
nYears(rating(nObs)) = nYears(rating(nObs)) + (lastDate - eventDate(nObs)) / 365
For i = 1 To nRatings
sumOffDiag = 0
If nYears(i) > 0 Then
For j = 1 To nRatings
transitionRate(i, j) = nTransitions(i, j) / nYears(i)
If i <> j Then sumOffDiag = sumOffDiag + transitionRate(i, j)
Next j
End If
transitionRate(i, i) = -sumOffDiag
Next i
RateMatrix = transitionRate
End Function
Function MatrixAdd(ByVal array1, ByVal array2)
' This adds two matrices. Normally, there should be a check on whether they
' have the same dimensions, but this is assured for this program.
Dim i As Integer, j As Integer, nRows As Integer, nCols As Integer, sum
nRows = UBound(array1, 1)
nCols = UBound(array1, 2)
ReDim sum(1 To nRows, 1 To nCols)
For i = 1 To nRows
For j = 1 To nCols
sum(i, j) = array1(i, j) + array2(i, j)
Next j
Next i
MatrixAdd = sum
End Function
Function MatrixMult(ByVal array1, ByVal array2)
' If array1 is a number, multiply each element of array2 by this number.
' Otherwise, matrix multiply array1 by array2.
Dim i As Integer, j As Integer, nRows As Integer, nCols As Integer
Dim scalar As Single, product
If Application.WorksheetFunction.Count(array1) = 1 Then
scalar = array1
nRows = UBound(array2, 1)
nCols = UBound(array2, 2)
ReDim product(1 To nRows, 1 To nCols)
For i = 1 To nRows
For j = 1 To nCols
product(i, j) = scalar * array2(i, j)
Next j
Next i
MatrixMult = product
Else
MatrixMult = Application.WorksheetFunction.MMult(array1, array2)
End If
End Function
Function MatrixDiag(m As Integer, d As Double)
'Generate diagonal mxm matrix with entries d on diagional
Dim i As Integer, j As Integer, diagMat
ReDim diagMat(1 To m, 1 To m)
For i = 1 To m
For j = 1 To m
diagMat(i, j) = 0
Next j
diagMat(i, i) = d
Next i
MatrixDiag = diagMat
End Function
Function MatrixExp(Q, t As Single)
' For a given square matrix Q, this function calculates the matrix exp(Q * t)
' as the limit of a power series, that is, the sum of (Q^k)*(t^k)/Fact(k).
Dim error As Double, k As Long
Dim sum, Q_k, matrixAdded
'First entry (identity matrix)
sum = MatrixDiag(UBound(Q, 1), 1)
k = 1
error = 1
Do While (error > 10 ^ (-10) And k <= 170) 'Because fact(k) does not work for k>170
' Calculate the kth power of Q
If k = 1 Then
Q_k = Q
Else
Q_k = MatrixMult(Q_k, Q)
End If
' Multiply Q^k by t^k/Fact(k)
matrixAdded = MatrixMult(t ^ k / Application.WorksheetFunction.Fact(k), Q_k)
' Running sum (first k+1 terms of power series, including identity)
sum = MatrixAdd(matrixAdded, sum)
k = k + 1
' Eventually, the matrix added should be very close to 0
If k > 10 Then error = Application.WorksheetFunction.SumSq(matrixAdded)
Loop
MatrixExp = sum
End Function
Function TransProb(Q, t As Single)
' The function calculates the t-year transition probability matrix as exp(Q*t), where
' Q is the infinitesimal generator matrix. This is done by calculating the corresponding
' power series, the sum of (Q^k)*(t^k)/Fact(k). However, the negative diagonal values in Q
' can cause numerical roundoff problems, so Q is first made all nonnegative by adding
' the largest diagonal (in magnitude) to all diagonal elements. Then this addition is
' essentially undone in the last step of the procedure.
Dim n As Integer, maxDiag As Double
Dim i As Integer, array1, nonnegQ, tmp
array1 = Q
n = UBound(array1)
' Find maximal diagonal entry
maxDiag = 0
For i = 1 To n
If Abs(array1(i, i)) > maxDiag Then maxDiag = Abs(array1(i, i))
Next i
' Modify Q so that its diagonal entries are all nonnegative.
nonnegQ = MatrixAdd(MatrixDiag(n, maxDiag), array1)
' Find exp(nonnegQ * t)
tmp = MatrixExp(nonnegQ, t)
' Find exp(Q * t), the desired matrix.
TransProb = MatrixMult(Exp(-maxDiag * t), tmp)
End Function
