马尔可夫链求转移矩阵

Option Explicit


Sub getMatrix(rng As Range)
Dim a(), d(), f(), g(), m(), k(), arr(1 To 3)
Dim b As Integer, c As Integer, i As Integer, j As Integer
Dim h
b = rng.Count
a = rng
ReDim Preserve a(1 To b, 1 To 2)
For i = 1 To UBound(a, 1)
a(i, 2) = standard(a(i, 1))
Next

d = Application.Index(a, , 2)

Dim e(1 To 3, 1 To 3)
For i = 1 To 3
For j = 1 To 3
e(i, j) = getStatusCount(d, i, j)
Next
Next

f = Application.WorksheetFunction.Transpose(e)

For i = 1 To 3
g = Application.Index(f, i)
arr(i) = Application.Sum(g)
Next

For j = 1 To 3
For i = 1 To 3
f(i, j) = f(i, j) / arr(j)
Next
Next

m = Application.WorksheetFunction.Transpose(f)


k = mmultn(m, 3)

Range("c1").Resize(3, 3) = k

End Sub

Function getStatusCount(ByRef m, ByVal x As Integer, ByVal y As Integer)
Dim i As Integer
getStatusCount = 0
For i = 1 To UBound(m) - 1
If m(i, 1) = x And m(i + 1, 1) = y Then getStatusCount = getStatusCount + 1
Next
End Function
Function standard(ByVal i As Integer) As Integer
Select Case i
Case Is < 100
standard = 1
Case Is > 150
standard = 3
Case Else
standard = 2
End Select
End Function
Function mmultn(a As Variant, n As Integer) As Variant
Dim temp As Variant
Dim i As Integer
temp = a
For i = 1 To n - 1
a = Application.WorksheetFunction.MMult(a, temp)
Next i
mmultn = a

End Function