在 VBA 中动态标注二维数组
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25327355/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
提示：将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间：2020-09-12 04:15:29 来源:igfitidea点击:
Dynamically dimension a two-dimensional array in VBA
提问by Alec Brady
I'm modelling Petri nets using VBA in Excel, and I want to be able to vary the number of species and transitions, and the links between them. I'm hoping to do this by reading straight off the Shapes used to draw the network, rather than explicitly inputting the matrices. This means I have to dynamically dimension my array variables. I can do this for the one-dimensional arrays, but the Species-Transition links require two-dimensional arrays. Is there any way of doing this, or will I have to fall back on using the spreadsheet to store my variables in?
我正在 Excel 中使用 VBA 对 Petri 网进行建模，我希望能够改变物种和转变的数量以及它们之间的联系。我希望通过直接读取用于绘制网络的形状来做到这一点，而不是明确输入矩阵。这意味着我必须动态地标注我的数组变量。我可以对一维数组执行此操作，但 Species-Transition 链接需要二维数组。有什么办法可以做到这一点，还是我必须依靠电子表格来存储我的变量？
回答by Blackhawk
As requested, here is the clsMatrixclass I had put together for my purposes; hopefully it can serve yours as well.
根据要求，这是clsMatrix我为我的目的而组合的课程；希望它也可以为您服务。
It includes:
这包括：
- Matrix operations -
Add,Subtract,Multiply,ScalarMultiply,Augment,Transpose - Elementary Row Operations -
SwapRows,ScaleRow,AddScalarMultipleRow - A Parser for loading the Matrix from a String -
LoadMatrixString - Utility functions -
toString,Clone - An implementation of Gaussian Elimination -
RowReduce
- 矩阵运算 -
Add,Subtract,Multiply,ScalarMultiply,Augment,Transpose - 基本行操作 -
SwapRows,ScaleRow,AddScalarMultipleRow - 用于从字符串加载矩阵的解析器 -
LoadMatrixString - 实用功能 -
toString,Clone - 高斯消元法的实现 -
RowReduce
Here are a couple examples of usage:
以下是几个用法示例：
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
And here is the clsMatrixclass:
这是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
If you should decide to try it and if you should encounter any problems/issues/unhandled exceptions, it would be very helpful to me if you could make note of them in a comment below.
如果您决定尝试一下，并且遇到任何问题/问题/未处理的异常，如果您能在下面的评论中记下它们，那将对我非常有帮助。
回答by Dan Wagner
Suppose your worksheet looks like this:
假设您的工作表如下所示：
You could dynamically allocate a MyArrayvariable like this:
您可以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
