Question

我在Excel中使用VBA对Petri网建模，我希望能够改变物种和过渡的数量，以及它们之间的联系。我希望通过直接读取用于绘制网络的形状来实现这一点，而不是明确地输入矩阵。这意味着我必须动态标注我的数组变量。我可以为一维数组执行此操作，但Species-Transition链接需要二维数组。有没有办法做到这一点，还是我不得不依靠使用电子表格来存储我的变量？

Answer 1

根据要求，这是我为了我的目的而放在一起的clsMatrix课程;希望它也能为你服务。

它包括：

矩阵操作 - Add，Subtract，Multiply，ScalarMultiply，Augment，Transpose
基本行操作 - SwapRows，ScaleRow，AddScalarMultipleRow
用于从字符串加载Matrix的解析器 - LoadMatrixString
效用函数 - toString，Clone
高斯消除的实现 - RowReduce

以下是几个用法示例：

Public Sub TestMatrix()

    Dim m1 As clsMatrix
    Set m1 = New clsMatrix
    m1.LoadMatrixString ("[[1,-3,1]," & _
                         " [1,1,-1]," & _
                         " [3,11,5]]")


    Dim m2 As clsMatrix
    Set m2 = New clsMatrix
    m2.LoadMatrixString ("[[9]," & _
                        " [1]," & _
                        " [35]]")

    MsgBox m1.Augment(m2).RowReduce.toString

End Sub

Public Sub TestMatrix2()
    'This is an example iteration of a matrix Petri Net as described here:
    'http://www.techfak.uni-bielefeld.de/~mchen/BioPNML/Intro/MRPN.html
    Dim D_Minus As clsMatrix
    Dim D_Plus As clsMatrix
    Dim D As clsMatrix

    Set D_Minus = New clsMatrix
    D_Minus.LoadMatrixString "[[0, 0, 0, 0, 1]," & _
                             " [1, 0, 0, 0, 0]," & _
                             " [0, 1, 0, 0, 0]," & _
                             " [0, 0, 1, 1, 0]]"

    Set D_Plus = New clsMatrix
    D_Plus.LoadMatrixString "[[1, 1, 0, 0, 0]," & _
                            " [0, 0, 1, 1, 0]," & _
                            " [0, 0, 0, 1, 0]," & _
                            " [0, 0, 0, 0, 1]]"


    Set D = D_Plus.Subtract(D_Minus)

    MsgBox D.toString

    Dim Transition_Matrix As clsMatrix
    Dim Marking_Matrix As clsMatrix
    Dim Next_Marking As clsMatrix

    Set Transition_Matrix = New clsMatrix
    Transition_Matrix.LoadMatrixString "[[0, 1, 1, 0]]"

    Set Marking_Matrix = New clsMatrix
    Marking_Matrix.LoadMatrixString "[[2, 1, 0, 0, 0]]"

    Set Next_Marking = Transition_Matrix.Multiply(D).Add(Marking_Matrix)

    MsgBox Next_Marking.toString

End Sub

这是clsMatrix类：

Option Compare Database
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private m_Arr() As Double

Private m_strMatrix As String
Private Look As String

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
End Type

Private Type ARRAY_VARIANT
    vt As Integer
    wReserved1 As Integer
    wReserved2 As Integer
    wReserved3 As Integer
    lpSAFEARRAY As Long
    data(4) As Byte
End Type

Private Enum tagVARENUM
    VT_EMPTY = &H0
    VT_NULL
    VT_I2
    VT_I4
    VT_R4
    VT_R8
    VT_CY
    VT_DATE
    VT_BSTR
    VT_DISPATCH
    VT_ERROR
    VT_BOOL
    VT_VARIANT
    VT_UNKNOWN
    VT_DECIMAL
    VT_I1 = &H10
    VT_UI1
    VT_UI2
    VT_I8
    VT_UI8
    VT_INT
    VT_VOID
    VT_HRESULT
    VT_PTR
    VT_SAFEARRAY
    VT_CARRAY
    VT_USERDEFINED
    VT_LPSTR
    VT_LPWSTR
    VT_RECORD = &H24
    VT_INT_PTR
    VT_UINT_PTR
    VT_ARRAY = &H2000
    VT_BYREF = &H4000
End Enum

Public Sub Class_Initialize()

End Sub

'************************************************
'* Accessors and Utility Functions *
'***********************************

Public Property Get Value(r As Long, c As Long) As Double

    CheckDimensions

    Value = m_Arr(r, c)
End Property

Public Property Let Value(r As Long, c As Long, val As Double)

    CheckDimensions

    m_Arr(r, c) = val
End Property

Public Property Get Rows() As Long
    If GetDims(m_Arr) = 0 Then
        Rows = 0
    Else
        Rows = UBound(m_Arr, 1) + 1
    End If
End Property

Public Property Get Cols() As Long
    If GetDims(m_Arr) = 0 Then
        Cols = 0
    Else
        Cols = UBound(m_Arr, 2) + 1
    End If
End Property

Public Sub LoadMatrixString(str As String)
    m_strMatrix = str
    ParseMatrix str
    m_strMatrix = ""
    Look = ""
End Sub

Public Sub Resize(Rows As Long, Cols As Long, Optional blPreserve As Boolean = False)
    Dim tempMatrix As clsMatrix
    Dim r As Long
    Dim c As Long

    If blPreserve Then

        CheckDimensions

        Set tempMatrix = Me.Clone
        ReDim m_Arr(0 To Rows - 1, 0 To Cols - 1)
        For r = 0 To MinLongs(tempMatrix.Rows, Me.Rows) - 1
            For c = 0 To MinLongs(tempMatrix.Cols, Me.Cols) - 1
                Value(r, c) = tempMatrix.Value(r, c)
            Next
        Next
    Else
        ReDim m_Arr(0 To Rows - 1, 0 To Cols - 1)
    End If

End Sub

Public Function Clone() As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions

    Set mresult = New clsMatrix
    mresult.Resize Me.Rows, Me.Cols
    For r = 0 To Me.Rows - 1
        For c = 0 To Me.Cols - 1
            mresult.Value(r, c) = Me.Value(r, c)
        Next
    Next
    Set Clone = mresult
End Function

Public Function toString() As String
    Dim str As String
    Dim r As Long
    Dim c As Long
    Dim tempRow() As String
    Dim tempRows() As String
    ReDim tempRow(0 To Me.Cols - 1)
    ReDim tempRows(0 To Me.Rows - 1)


    If Not GetDims(m_Arr) = 0 Then 'Need to check if array is empty
        For r = 0 To Me.Rows - 1
            For c = 0 To Me.Cols - 1
                tempRow(c) = Me.Value(r, c)
            Next
            tempRows(r) = "[" & Join(tempRow, ", ") & "]"
        Next
        toString = "[" & Join(tempRows, vbCrLf) & "]"
    Else
        toString = ""
    End If
End Function

'***********************************************************
'* Matrix Operations *
'*********************

Public Function Add(m As clsMatrix) As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions

    If m.Rows = Me.Rows And m.Cols = Me.Cols Then
        Set mresult = New clsMatrix
        mresult.Resize Me.Rows, Me.Cols
        For r = 0 To Me.Rows - 1
            For c = 0 To Me.Cols - 1
                mresult.Value(r, c) = Me.Value(r, c) + m.Value(r, c)
            Next
        Next
    Else
        Err.Raise vbObjectError + 1, "clsMatrix.Add", "Could not Add matrices: the Rows and Columns must be the same. The left matrix is (" & Me.Rows & ", " & Me.Cols & ") and the right matrix is (" & m.Rows & ", " & m.Cols & ")."
    End If
    Set Add = mresult
End Function

Public Function Subtract(m As clsMatrix) As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions

    If m.Rows = Me.Rows And m.Cols = Me.Cols Then
        Set mresult = New clsMatrix
        mresult.Resize Me.Rows, Me.Cols
        For r = 0 To Me.Rows - 1
            For c = 0 To Me.Cols - 1
                mresult.Value(r, c) = Me.Value(r, c) - m.Value(r, c)
            Next
        Next
    Else
        Err.Raise vbObjectError + 2, "clsMatrix.Subtract", "Could not Subtract matrices: the Rows and Columns must be the same. The left matrix is (" & Me.Rows & ", " & Me.Cols & ") and the right matrix is (" & m.Rows & ", " & m.Cols & ")."
    End If
    Set Subtract = mresult
End Function

Public Function Multiply(m As clsMatrix) As clsMatrix
    Dim mresult As clsMatrix
    Dim i As Long
    Dim j As Long
    Dim n As Long

    CheckDimensions

    If Me.Cols = m.Rows Then
        Set mresult = New clsMatrix
        mresult.Resize Me.Rows, m.Cols
        For i = 0 To Me.Rows - 1
            For j = 0 To m.Cols - 1
                For n = 0 To Me.Cols - 1
                    mresult.Value(i, j) = mresult.Value(i, j) + (Me.Value(i, n) * m.Value(n, j))
                Next
            Next
        Next
    Else
        Err.Raise vbObjectError + 3, "clsMatrix.Multiply", "Could not Subtract matrices: the Columns of the left matrix and Rows of the right must be the same. The left matrix has " & Me.Cols & " Columns and the right matrix has " & m.Rows & " Rows."
    End If

    Set Multiply = mresult

End Function

Public Function ScalarMultiply(scalar As Double) As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions

    Set mresult = New clsMatrix
    mresult.Resize Me.Rows, Me.Cols
    For r = 0 To Me.Rows - 1
        For c = 0 To Me.Cols - 1
            mresult.Value(r, c) = Me.Value(r, c) * scalar
        Next
    Next

    Set ScalarMultiply = mresult

End Function

Public Function Augment(m As clsMatrix) As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions


    If Me.Rows = m.Rows Then
        Set mresult = New clsMatrix
        mresult.Resize Me.Rows, Me.Cols + m.Cols
        For r = 0 To Me.Rows - 1
            For c = 0 To Me.Cols - 1
                mresult.Value(r, c) = Me.Value(r, c)
            Next
        Next

        For r = 0 To Me.Rows - 1
            For c = 0 To m.Cols - 1
                mresult.Value(r, Me.Cols + c) = m.Value(r, c)
            Next
        Next
    Else
        Err.Raise vbObjectError + 4, "clsMatrix.Augment", "Could not Augment matrices: the matrices must have the same number of Rows. The left matrix has " & Me.Rows & " Rows and the right matrix has " & m.Rows & " Rows."
    End If
    Set Augment = mresult
End Function

Public Function Transpose() As clsMatrix
    Dim mresult As clsMatrix
    Dim r As Long
    Dim c As Long

    CheckDimensions

    If Me.Rows = Me.Cols Then
        Set mresult = New clsMatrix
        mresult.Resize Me.Cols, Me.Rows
        For r = 0 To Me.Rows - 1
            For c = 0 To Me.Cols - 1
                Me.Value(r, c) = mresult(c, r)
            Next
        Next
    Else
        Err.Raise vbObjectError + 5, "clsMatrix.Augment", "Could not Transpose matrix: the matrix must have the same number of Rows and Cols. The matrix is (" & Me.Rows & ", " & Me.Cols & ")."
    End If
    Set Transpose = mresult
End Function

Public Function RowReduce() As clsMatrix
    Dim i As Long
    Dim j As Long

    CheckDimensions

    'Row Echelon
    Dim mresult As clsMatrix
    Set mresult = Me.Clone

    For i = 0 To mresult.Rows - 1
        If Not mresult.Value(i, i) <> 0 Then
            For j = i + 1 To mresult.Rows - 1
                If mresult.Value(j, i) > 0 Then
                    mresult.SwapRows i, j
                    Exit For
                End If
            Next
        End If

        If mresult.Value(i, i) = 0 Then
            Exit For
        End If

        mresult.ScaleRow i, 1 / mresult.Value(i, i)

        For j = i + 1 To mresult.Rows - 1
            mresult.AddScalarMultipleRow i, j, -mresult.Value(j, i)
        Next
    Next

    'Backwards substitution

    For i = IIf(mresult.Rows < mresult.Cols, mresult.Rows, mresult.Cols) - 1 To 1 Step -1
        If mresult.Value(i, i) > 0 Then
            For j = i - 1 To 0 Step -1
                mresult.AddScalarMultipleRow i, j, -mresult.Value(j, i)
            Next
        End If
    Next

    Set RowReduce = mresult
End Function


'*************************************************************
'* Elementary Row Operaions *
'****************************

Public Sub SwapRows(r1 As Long, r2 As Long)
    Dim temp As Double
    Dim c As Long

    CheckDimensions

    For c = 0 To Me.Cols - 1
        temp = Me.Value(r1, c)
        Me.Value(r1, c) = Me.Value(r2, c)
        Me.Value(r2, c) = temp
    Next
End Sub

Public Sub ScaleRow(row As Long, scalar As Double)
    Dim c As Long

    CheckDimensions

    For c = 0 To Me.Cols - 1
        Me.Value(row, c) = Me.Value(row, c) * scalar
    Next
End Sub

Public Sub AddScalarMultipleRow(srcrow As Long, destrow As Long, scalar As Double)
    Dim c As Long

    CheckDimensions

    For c = 0 To Me.Cols - 1
        Me.Value(destrow, c) = Me.Value(destrow, c) + (Me.Value(srcrow, c) * scalar)
    Next
End Sub

'************************************************************
'* Parsing Functions *
'*********************

Private Sub ParseMatrix(strMatrix As String)
    Dim arr() As Double
    Dim c As Long
    GetChar 1
    Match "["
    SkipWhite
    If Look = "[" Then
        arr = ParseRow
        Me.Resize 1, UBound(arr) + 1
        'ReDim m_Arr(0 To UBound(arr), 0 To 0)
        For c = 0 To Me.Cols - 1
            Me.Value(0, c) = arr(c)
        Next
        SkipWhite
        While Look = ","
            Match ","
            SkipWhite
            arr = ParseRow
            Me.Resize Me.Rows + 1, Me.Cols, True

            If UBound(arr) <> (Me.Cols - 1) Then
                'Error jagged array
                Err.Raise vbObjectError + 6, "clsMatrix.LoadMatrixString", "Parser Error - Jagged arrays are not supported: Row 0 has " & Me.Cols & " Cols, but Row " & Me.Rows - 1 & " has " & UBound(arr) + 1 & " Cols."
            End If
            For c = 0 To Me.Cols - 1
                Me.Value(Me.Rows - 1, c) = arr(c)
            Next
            SkipWhite
        Wend
        Match "]"
    ElseIf Look = "]" Then
        Match "]"
    Else
        MsgBox "Error"
    End If
    SkipWhite
    If Look <> "" Then
        Err.Raise vbObjectError + 7, "clsMatrix.LoadMatrixString", "Parser Error - Unexpected Character: """ & Look & """."
    End If
End Sub

Private Function ParseRow() As Variant
    Dim arr() As Double
    Match "["
    SkipWhite
    ReDim arr(0 To 0)
    arr(0) = ParseNumber
    SkipWhite
    While Look = ","
        Match ","
        ReDim Preserve arr(0 To UBound(arr) + 1)
        arr(UBound(arr)) = ParseNumber
        SkipWhite
    Wend
    Match "]"
    ParseRow = arr
End Function

Private Function ParseNumber() As Double
    Dim strToken As String
    If Look = "-" Then
        strToken = strToken & Look
        GetChar
    End If
    While IsDigit(Look)
        strToken = strToken & Look
        GetChar
    Wend
    If Look = "." Then
        strToken = strToken & Look
        GetChar
        While IsDigit(Look)
            strToken = strToken & Look
            GetChar
        Wend
    End If

    ParseNumber = CDbl(strToken)
End Function

'****************************************************************

Private Sub GetChar(Optional InitValue)
    Static i As Long
    If Not IsMissing(InitValue) Then
        i = InitValue
    End If
    If i <= Len(m_strMatrix) Then
        Look = Mid(m_strMatrix, i, 1)
        i = i + 1
    Else
        Look = ""
    End If
End Sub

'****************************************************************
'* Skip Functions *
'******************

Private Sub SkipWhite()
    While IsWhite(Look) Or IsEOL(Look)
        GetChar
    Wend
End Sub

'****************************************************************
'* Match/Expect Functions *
'**************************

Private Sub Match(char As String)
    If Look <> char Then
        Expected """" & char & """"
    Else
        GetChar
        SkipWhite
    End If
    Exit Sub

End Sub

Private Sub Expected(str As String)
    'MsgBox "Expected: " & str
    Err.Raise vbObjectError + 8, "clsMatrix.LoadMatrixString", "Parser Error - Expected: " & str
End Sub

'****************************************************************
'* Character Class Functions *
'*****************************

Private Function IsDigit(char As String) As Boolean

    Dim charval As Integer
    If char <> "" Then
        charval = Asc(char)
        If 48 <= charval And charval <= 57 Then
            IsDigit = True
        Else
            IsDigit = False
        End If
    Else
        IsDigit = False
    End If

End Function

Private Function IsWhite(char As String) As Boolean

    Dim charval As Integer
    If char <> "" Then
        charval = Asc(char)
        If charval = 9 Or charval = 11 Or charval = 12 Or charval = 32 Or charval = 160 Then '160 because MS Exchange sucks
            IsWhite = True
        Else
            IsWhite = False
        End If
    Else
        IsWhite = False
    End If

End Function

Private Function IsEOL(char As String) As Boolean
    If char = Chr(13) Or char = Chr(10) Then
        IsEOL = True
    Else
        IsEOL = False
    End If
End Function

'*****************************************************************
'* Helper Functions *
'********************

Private Sub CheckDimensions()
    If GetDims(m_Arr) = 0 Then
        'Error, uninitialized array
        Err.Raise vbObjectError + 1, "clsMatrix", "Array has not been initialized"
    End If
End Sub

Private Function GetDims(VarSafeArray As Variant) As Integer
    Dim varArray As ARRAY_VARIANT
    Dim lpSAFEARRAY As Long
    Dim sArr As SAFEARRAY
    CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
    If varArray.vt And (tagVARENUM.VT_ARRAY Or tagVARENUM.VT_BYREF) Then
        CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
        If Not lpSAFEARRAY = 0 Then
            CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
            GetDims = sArr.cDims
        Else
            GetDims = 0  'The array is uninitialized
        End If
    Else
        GetDims = 0  'Not an array
    End If
End Function

Private Function MinLongs(a As Long, b As Long) As Long
    If a < b Then
        MinLongs = a
    Else
        MinLongs = b
    End If
End Function

如果您决定尝试一下，如果您遇到任何问题/问题/未处理的例外情况，如果您可以在下面的评论中记下它们，对我来说会非常有帮助。

Answer 2

假设您的工作表如下所示：

start

您可以像这样动态分配MyArray变量：

Option Explicit
Sub DynamicDimension()

Dim NumRows As Long, NumCols As Long
Dim MyArray As Variant

'collect the number of rows from cell A1
'and the number of columns from cell B1
NumRows = Worksheets("Sheet1").Range("A1").Value
NumCols = Worksheets("Sheet1").Range("B1").Value

'allocate array with dimensions collected from A1 and B1
ReDim MyArray(1 To NumRows, 1 To NumCols)

'output with message box to show that array is correctly dimensioned
MsgBox ("MyArray has " & UBound(MyArray, 1) & " rows.")
MsgBox ("MyArray has " & UBound(MyArray, 2) & " cols.")

End Sub

end1 end2

在VBA中动态标注二维数组

2 个答案: