dynamic维度VBA中的二维数组
我在Excel中使用VBAbuild模Petri网，我希望能够改变物种和转换的数量，以及它们之间的联系。 我希望通过直接读取用于绘制networking的形状而不是明确地inputmatrix来实现这一点。 这意味着我必须dynamic地维度我的数组variables。 我可以做一维数组，但物种转换链接需要二维数组。 有没有办法做到这一点，或者我将不得不使用电子表格来存储我的variables？
假设你的工作表是这样的：
你可以像这样dynamic分配一个MyArrayvariables：
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
按照要求，这里是我为了我的目的拼凑的clsMatrix类。 希望它也能为你服务。
这包括：
- matrix运算 –
Add，Subtract，Multiply，ScalarMultiplyMultiply，ScalarMultiply，ScalarMultiply - 基本行操作 –
SwapRows，ScaleRow，AddScalarMultipleRow - 从string加载Matrix的parsing器 –
LoadMatrixString - 实用function –
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
如果你决定尝试一下，如果你遇到任何问题/问题/未经处理的例外情况，如果你能在下面的评论中记下它们，那对我来说是非常有帮助的。