Related
I am currently reading a range into an array to perform a few calculations before outputting into another worksheet. My reason for using the array is speed as I am often dealing with thousands of rows.
I have one particular calculation that I am struggling with for some reason.
This is the part I am struggling with (rest of sample of this code is further down):
For i = non_rev_rows To 2 Step -1.
**' Remove Blank Rows from array
If data_range(i, 2) = "No WBS/CC" Then
If Application.WorksheetFunction.CountA(Range("C" & i & ":M" & i)) = 0 Then
Rows(i).Delete
End If
So basically when a row in column 2 is equal to "No WBS/CC" then I need to run a CountA or any other method you can recommend to calcuate the total value of columns C to M on that row. I am essentially looking for any row that = "No WBS/CC" and where columns C:M have no value. If so, then delete the entire row. If there is a value in columns C:M then I would not wish to delete the row.
'Row Count
With Sheets("array")
non_rev_rows = .Range("E" & .Rows.Count).End(xlUp).Row
End With
' Remove Blank Rows from array
' Replace "NO WBS/CC" with Co Code Over-Ride if supplied
' Set Debit / Credit
' Round to 2 decimal places
Set data = array_sheet.Range("A1:M" & non_rev_rows)
data_range = data.Value
For i = non_rev_rows To 2 Step -1.
**' Remove Blank Rows from array
If data_range(i, 2) = "No WBS/CC" Then
If Application.WorksheetFunction.CountA(Range("C" & i & ":M" & i)) = 0 Then
Rows(i).Delete
End If
' Replace "NO WBS/CC" with Co Code Over-Ride if supplied
If data_range(i, 13) <> 0 Then
data_range(i, 2) = data_range(i, 13)
End If
End If**
' Set Debit / Credit
data_range(i, 3) = Replace(data_range(i, 3), "Debit", 41)
data_range(i, 3) = Replace(data_range(i, 3), "Credit", 51)
' Round to 2 decimal places
data_range(i, 5) = WorksheetFunction.Round(data_range(i, 5), 2)
' If data_range(i, 3) = "Debit" Then
' data_range(i, 3).Value = 41
' ElseIf data_range(i, 3) = "Credit" Then
' data_range(i, 3).Value = 51
' End If
'data_range(i, 5).Value = Application.WorksheetFunction.Round(Range(data_range(i, 5)).Value, 2)
'Range("E" & i).Value = Application.WorksheetFunction.Round(Range("E" & i).Value, 2)
Next i
**' Remove Blank Rows from array
If data_range(i, 2) = "No WBS/CC" Then
If Application.WorksheetFunction.CountA(Range("C" & i & ":M" & i)) = 0 Then
Rows(i).Delete
End If
This code does not result in an error but it also does not have the desired impact. I have several rows in my test data that contain "No WBS/CC" in column 2 and zero values in columns C:M but the code is not deleting those rows.
If you want learning/understanding how an array row can be deleted (adapted for your case), please test the next way. It will return the array without deleted rows starting from "O2" of the same sheet, so the range after M:M column must be empty. You can easily adapt last code line to return wherever you need (in other sheet, other workbook...):
Sub DeleteArrayRows()
Dim array_sheet As Worksheet, non_rev_rows As Long, Data As Range, count2 As Long, data_range, arrRow, i As Long
Set array_sheet = ActiveSheet 'worksheets("array")
non_rev_rows = array_sheet.Range("E" & array_sheet.rows.count).End(xlUp).row
Set Data = array_sheet.Range("A1:M" & non_rev_rows)
data_range = Data.Value
For i = 1 To UBound(data_range)
count2 = 0
If data_range(i, 2) = "No WBS/CC" Then
With Application
arrRow = .Transpose(.Transpose(.Index(data_range, i, 0))) 'extract a slice of the row array
End With
Debug.Print Join(arrRow, ""): Stop 'just to see the joinned respecitve slice In Immediate Window
'comment it after seeing what it represents and press F5
If data_range(i, 1) <> "" Then count2 = Len(data_range(i, 1))
If Len(Join(arrRow, "")) - count2 = Len(data_range(i, 2)) Then
data_range = DeleteArrayRow_(data_range, i): i = i - 1
End If
End If
If i = UBound(data_range) Then Exit For
Next i
'drop the array (without deleted rows) in a range:
array_sheet.Range("O1").Resize(UBound(data_range), UBound(data_range, 2)).Value = data_range
End Sub
Private Function DeleteArrayRow_(arr As Variant, RowToDelete As Long) As Variant 'interesting...
'It does not work to eliminate the first array row...
Dim Rws As Long, cols As String
Rws = UBound(arr) - LBound(arr)
cols = "A:" & Split(Columns(UBound(arr, 2) - LBound(arr, 2) + 1).address(, 0), ":")(0)
DeleteArrayRow_ = Application.Index(arr, Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & _
(RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & _
(RowToDelete + 1) & ":" & UBound(arr) & ")"))))), Evaluate("COLUMN(" & cols & ")"))
End Function
It is not extremely fast, I tried showing it only for didactic purpose. To see that it is and how it is possible...
Note: I did not pay attention to all at the code lines after deletion. It can be easily adapted to include that part...
You can do both tests on the array rather than partially in array and partially in the worksheet.
Only delete the row in the worksheet when you find a full match.
Public Sub Test2()
Dim data_range As Variant
Dim lRows As Long
Dim lColumns As Long
Dim lCounter As Long
data_range = Sheet1.Range("A1:M6")
' Add the data to an array
For lRows = UBound(data_range) To LBound(data_range) Step -1
'Step through the array in reverse
If data_range(lRows, 2) = "No WBS/CC" Then
'Check for the "No WBS/CC" value in the second column of the array
lCounter = 0
'Reset the counter
For lColumns = 3 To 13
If Not IsEmpty(data_range(lRows, lColumns)) Then
lCounter = lCounter + 1
End If
Next lColumns
'Check columns in the array row to see if they have data
'Add to the counter for each cell having value
If lCounter = 0 Then
Sheet1.Rows(lRows).EntireRow.Delete
End If
'If the counter is zero delete the current row in the Workbook
End If
Next lRows
End Sub
Sample data before the macro is run. The row we expected to be removed highlighted in green.
Sample data after the macro is run. The expected row has been removed.
An alternate option is to write the valid rows to a new array.
Clear the data on the worksheet, then write the new array to the worksheet.
Remove Rows
Sub DoStuff()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Array")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Dim rg As Range: Set rg = ws.Range("A2", ws.Cells(LastRow, "M"))
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count
Dim Data() As Variant: Data = rg.Value
Dim sr As Long
Dim dr As Long
Dim c As Long
For sr = 1 To rCount
If Not IsRowBlank(Data, sr, 3, 13) Then ' is not blank
' Replace "NO WBS/CC" with Co Code Over-Ride if supplied
If CStr(Data(sr, 1)) = "No WBS/CC" Then
If Data(sr, 13) <> 0 Then
Data(sr, 2) = Data(sr, 13)
End If
End If
' Set Debit / Credit
Data(sr, 3) = Replace(Data(sr, 3), "Debit", 41)
Data(sr, 3) = Replace(Data(sr, 3), "Credit", 51)
' Round to 2 decimal places
Data(sr, 5) = Application.Round(Data(sr, 5), 2)
' Copy source row to destination row.
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
'Else ' is blank; do nothing
End If
Next sr
' Clear bottom source data.
If dr < rCount Then
For sr = dr + 1 To rCount
For c = 1 To cCount
Data(sr, c) = Empty
Next c
Next sr
End If
rg.Value = dData
End Sub
Function IsRowBlank( _
Data() As Variant, _
ByVal DataRow As Long, _
ByVal StartColumn As Long, _
ByVal EndColumn As Long) _
As Boolean
Dim c As Long
For c = StartColumn To EndColumn
If Len(CStr(Data(DataRow, c))) > 0 Then Exit For
Next c
IsRowBlank = c > EndColumn
End Function
Is there a way to have this script form the entire array based off the rows I want it to extract based on the IF Statement?
I know this finds a name on the Mgrs worksheet, and finds those rows in the Data worksheet, but then it directly prints it after forming the array. Can I have this code store all of the data, and then wait to print the data on a template that I format myself?
Option Explicit
Sub CIB_Cuts()
Dim j As Long, k As Long, x As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 19, 1 To 1)
Dim strManager As String, strEC As String, strLogin As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long
Dim colManager As Long
colManager = 3
Dim colLogin As Long
colLogin = 4
Dim colEC As Long
colEC = 5
BASEPATH = "M:\Final Files\"
Call speedupcode(True)
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3)
With ThisWorkbook.Worksheets("Data")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 2 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
If k = 1 Then
varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))
Else
varArray(k, x) = .Cells(j, k)
End If
strEC = .Cells(j, colEC)
strManager = .Cells(j, colManager)
strLogin = .Cells(j, colLogin)
Next
End If
Next
End With
strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
.Columns(1).NumberFormat = "#"
.Columns(15).NumberFormat = "0%"
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
Call DataValidation
Call Header
.Range("C2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").Font.Bold = True
Call protect
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call speedupcode(False)
End Sub
You could store the array each time in an overarching array or a collection and loop that at the end...
Public Sub test()
Dim varArray2() As Variant, results As Collection
'other code..
Set results = New Collection
results.Add varArray2
End Sub
You could also use Select Case , or something distinctive during the loop, to determine a key and populate a dictionary with the arrays as values which might make retrieval of specific items easier.
I have a 20x3 table on an excel sheet. Each of the three columns is labeled Date, Price, and Volume. I want to convert this data into a .txt file that contains an array of array, i.e an array containing twenty arrays, where each of the twenty arrays has the format [Date, price, volume]. The final array should have the format:
[[Date_0, Price_0, Volume_0], . . .,[Date_19, Price_19, Volume_19]].
I believe this can be done by writing a loop for each row and printing as an array.
This is a modification from the above that will take input as a range. It is capable of handling ranges with several areas (multiselection).
Public Sub writeRangeToFile(ByRef rng As Range, ByVal path As String)
Dim fso As Object, _
fOut As Object, _
rArea As Range, _
row As Integer, _
col As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set fOut = fso.CreateTextFile(path, overwrite:=True, Unicode:=False)
With fOut
For Each rArea In rng.Areas '' iterate over areas of range, insures all are rects
fOut.Write "["
For row = 1 To rArea.Rows.Count Step 1
.Write IIf(row > 1, ",", "") & "["
For col = 1 To rArea.Columns.Count Step 1
.Write IIf(col > 1, ",", "") & rArea.Cells(row, col).Value
Next col
.Write "]"
Next row
.Write "]" & vbCrLf
Next rArea
.Close
End With
End Sub
Tester
This serves as a general test case, but I think you would want to use a named range in place of Selection in your case
Sub tester()
writeRangeToFile Selection, "C:\[your directory]\Test.txt"
End Sub
Output
Given the selection of
the tester function outputs
[[B2,C2,D2,E2,F2,G2],[B3,C3,D3,E3,F3,G3],[B4,C4,D4,E4,F4,G4],[B5,C5,D5,E5,F5,G5]]
[[M3,N3,O3,P3,Q3],[M4,N4,O4,P4,Q4],[M5,N5,O5,P5,Q5],[M6,N6,O6,P6,Q6],[M7,N7,O7,P7,Q7],[M8,N8,O8,P8,Q8]]
[[D10,E10,F10,G10,H10,I10,J10],[D11,E11,F11,G11,H11,I11,J11],[D12,E12,F12,G12,H12,I12,J12],[D13,E13,F13,G13,H13,I13,J13],[D14,E14,F14,G14,H14,I14,J14],[D15,E15,F15,G15,H15,I15,J15],[D16,E16,F16,G16,H16,I16,J16]]
[[Q15,R15,S15,T15],[Q16,R16,S16,T16],[Q17,R17,S17,T17],[Q18,R18,S18,T18],[Q19,R19,S19,T19],[Q20,R20,S20,T20]]
You can do this using the Open path For Output call, and then by iterating across the array in both directions.
Sub writeArrToFile(ByRef arr() As String, ByVal path As String)
Dim lOuter As Integer, _
uOuter As Integer, _
lInner As Integer, _
uInner As Integer
Open path For Output As #1
Let lOuter = LBound(arr(), 1)
Let uOuter = UBound(arr(), 1)
Let lInner = LBound(arr(), 2)
Let uInner = UBound(arr(), 2)
Print #1, "[";
For i = lOuter To uOuter
Print #1, IIf(i > lOuter, ",", ""); "[";
For j = lInner To uInner
Print #1, IIf(j > lInner, ",", ""); arr(i, j);
Next j
Print #1, "]";
Next i
Print #1, "]";
Close #1
End Sub
or you may achieve this by using a more modern, object oriented approach with
Sub writeArrToFile(ByRef arr() As String, ByVal path As String)
Dim fso As Object, _
fOut As Object, _
lInner As Integer, _
lOuter As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set fOut = fso.CreateTextFile(path, overwrite:=True, Unicode:=False)
Let lInner = LBound(arr(), 2)
Let uInner = UBound(arr(), 2)
With fOut
.Write "["
For i = LBound(arr(), 1) To UBound(arr(), 1) Step 1
.Write IIf(i > lOuter, ",", "") & "["
For j = lInner To uInner
.Write IIf(j > lInner, ",", "") & arr(i, j)
Next j
.Write "]"
Next i
.Write "]"
.Close
End With
End Sub
Tester Function
You can test the above with this function. Modify the file path to designate where the subroutine should output.
Sub tester()
Dim arr(0 To 2, 0 To 2) As String
arr(0, 0) = "a"
arr(0, 1) = "b"
arr(0, 2) = "c"
arr(1, 0) = "d"
arr(1, 1) = "e"
arr(1, 2) = "f"
arr(2, 0) = "g"
arr(2, 1) = "h"
arr(2, 2) = "i"
writeArrToFile arr, "C:\[your directory]\Test.txt"
End Sub
Output
The above tester function outputs to "C:\[your directory]\Test.txt"
[[a,b,c],[d,e,f],[g,h,i]]
Ubound can return the max index value of an array, but in a multidimensional array, how would I specify WHICH dimension I want the max index of?
For example
Dim arr(1 to 4, 1 to 3) As Variant
In this 4x3 array, how would I have Ubound return 4, and how would I have Ubound return 3?
ubound(arr, 1)
and
ubound(arr, 2)
You need to deal with the optional Rank parameter of UBound.
Dim arr(1 To 4, 1 To 3) As Variant
Debug.Print UBound(arr, 1) '◄ returns 4
Debug.Print UBound(arr, 2) '◄ returns 3
More at: UBound Function (Visual Basic)
[This is a late answer addressing the title of the question (since that is what people would encounter when searching) rather than the specifics of OP's question which has already been answered adequately]
Ubound is a bit fragile in that it provides no way to know how many dimensions an array has. You can use error trapping to determine the full layout of an array. The following returns a collection of arrays, one for each dimension. The count property can be used to determine the number of dimensions and their lower and upper bounds can be extracted as needed:
Function Bounds(A As Variant) As Collection
Dim C As New Collection
Dim v As Variant, i As Long
On Error GoTo exit_function
i = 1
Do While True
v = Array(LBound(A, i), UBound(A, i))
C.Add v
i = i + 1
Loop
exit_function:
Set Bounds = C
End Function
Used like this:
Sub test()
Dim i As Long
Dim A(1 To 10, 1 To 5, 4 To 10) As Integer
Dim B(1 To 5) As Variant
Dim C As Variant
Dim sizes As Collection
Set sizes = Bounds(A)
Debug.Print "A has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(B)
Debug.Print vbCrLf & "B has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(C)
Debug.Print vbCrLf & "C has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
End Sub
Output:
A has 3 dimensions:
1 to 10
1 to 5
4 to 10
B has 1 dimensions:
1 to 5
C has 0 dimensions:
UBound(myArray, 1) returns the number of rows in 2d array
UBound(myArray, 2) returns the number of columns in 2d array
However, let's go 1 step further and assume that you need the last row and last column of range, that has been written as a 2d array. That row (or column) should be converted to a 1d array. E.g. if our 2d array looks like this:
Then running the code below, will give you 2 1D arrays, that are the last column and last row:
Sub PrintMultidimensionalArrayExample()
Dim myRange As Range: Set myRange = Range("a1").CurrentRegion
Dim myArray As Variant: myArray = myRange
Dim lastRowArray As Variant: lastRowArray = GetRowFromMdArray(myArray, UBound(myArray, 1))
Dim lastColumnArray As Variant
lastColumnArray = GetColumnFromMdArray(myArray, UBound(myArray, 2))
End Sub
Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant
'returning a column from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 1)
ReDim result(size)
For i = LBound(myArray, 1) To UBound(myArray, 1)
result(i) = myArray(i, myCol)
Next
GetColumnFromMdArray = result
End Function
Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant
'returning a row from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 2)
ReDim result(size)
For i = LBound(myArray, 2) To UBound(myArray, 2)
result(i) = myArray(myRow, i)
Next
GetRowFromMdArray = result
End Function
In addition to the already excellent answers, also consider this function to retrieve both the number of dimensions and their bounds, which is similar to John's answer, but works and looks a little differently:
Function sizeOfArray(arr As Variant) As String
Dim str As String
Dim numDim As Integer
numDim = NumberOfArrayDimensions(arr)
str = "Array"
For i = 1 To numDim
str = str & "(" & LBound(arr, i) & " To " & UBound(arr, i)
If Not i = numDim Then
str = str & ", "
Else
str = str & ")"
End If
Next i
sizeOfArray = str
End Function
Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
' http://www.cpearson.com/excel/vbaarrays.htm
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Example usage:
Sub arrSizeTester()
Dim arr(1 To 2, 3 To 22, 2 To 9, 12 To 18) As Variant
Debug.Print sizeOfArray(arr())
End Sub
And its output:
Array(1 To 2, 3 To 22, 2 To 9, 12 To 18)
Looping D3 ways;
Sub SearchArray()
Dim arr(3, 2) As Variant
arr(0, 0) = "A"
arr(0, 1) = "1"
arr(0, 2) = "w"
arr(1, 0) = "B"
arr(1, 1) = "2"
arr(1, 2) = "x"
arr(2, 0) = "C"
arr(2, 1) = "3"
arr(2, 2) = "y"
arr(3, 0) = "D"
arr(3, 1) = "4"
arr(3, 2) = "z"
Debug.Print "Loop Dimension 1"
For i = 0 To UBound(arr, 1)
Debug.Print "arr(" & i & ", 0) is " & arr(i, 0)
Next i
Debug.Print ""
Debug.Print "Loop Dimension 2"
For j = 0 To UBound(arr, 2)
Debug.Print "arr(0, " & j & ") is " & arr(0, j)
Next j
Debug.Print ""
Debug.Print "Loop Dimension 1 and 2"
For i = 0 To UBound(arr, 1)
For j = 0 To UBound(arr, 2)
Debug.Print "arr(" & i & ", " & j & ") is " & arr(i, j)
Next j
Next i
Debug.Print ""
End Sub
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 8 years ago.
Improve this question
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?
As requested, here is the clsMatrix class I had put together for my purposes; hopefully it can serve yours as well.
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
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 clsMatrix class:
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.
Suppose your worksheet looks like this:
You could dynamically allocate a MyArray variable like this:
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