Dynamically dimension a two-dimensional array in VBA [closed] - arrays

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

Related

VBA array. Smallest element and its number

How to find smallest element of array V(12,9) and its number?
Private Sub Command2_Click()
Dim V(1 To 12, 1 To 9) As Integer
Randomize
For i = 1 To 12
For j = 1 To 9
V(i, j) = Rnd * 50
Next j
Next i
Identify the Minimum Value in a 2D Array
See the information and results in the Immediate window (Ctrl+G). It's nicer and more educational than the presentation in the message box.
With such small numbers you could replace all the Longs with Integers if that is a requirement. Here is a link describing why we mostly don't use Integer anymore.
Private Sub Command2_Click()
Const Max As Long = 50
' Populate the array.
Dim V(1 To 12, 1 To 9) As Long
Dim i As Long
Dim j As Long
Randomize
For i = 1 To 12
For j = 1 To 9
V(i, j) = Rnd * Max
Next j
Next i
Debug.Print GetDataString(V, , , "Random numbers from 0 to " & Max)
Debug.Print "How Min Was Changed in the Loop (It Started at " & Max & ")"
Debug.Print "The array was looped by rows."
Debug.Print "Visually find the following values to understand what happened."
Debug.Print "i", "j", "Min"
' Calculate the minimum.
Dim Min As Long: Min = Max
For i = 1 To 12
For j = 1 To 9
If V(i, j) < Min Then
Min = V(i, j)
Debug.Print i, j, Min
End If
Next j
Next i
Debug.Print "The minimum is " & Min & "."
MsgBox GetDataString(V, , , "Random numbers from 0 to " & Max) & vbLf _
& "The minimum is " & Min & ".", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a 2D array in a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDataString( _
ByVal Data As Variant, _
Optional ByVal RowDelimiter As String = vbLf, _
Optional ByVal ColumnDelimiter As String = " ", _
Optional ByVal Title As String = "PrintData Result") _
As String
' Store the limits in variables
Dim rLo As Long: rLo = LBound(Data, 1)
Dim rHi As Long: rHi = UBound(Data, 1)
Dim cLo As Long: cLo = LBound(Data, 2)
Dim cHi As Long: cHi = UBound(Data, 2)
' Define the arrays.
Dim cLens() As Long: ReDim cLens(rLo To rHi)
Dim strData() As String: ReDim strData(rLo To rHi, cLo To cHi)
' For each column ('c'), store strings of the same length ('cLen')
' in the string array ('strData').
Dim r As Long, c As Long
Dim cLen As Long
For c = cLo To cHi
' Calculate the current column's maximum length ('cLen').
cLen = 0
For r = rLo To rHi
strData(r, c) = CStr(Data(r, c))
cLens(r) = Len(strData(r, c))
If cLens(r) > cLen Then cLen = cLens(r)
Next r
' Store strings of the same length in the current column
' of the string array.
If c = cHi Then ' last row (no column delimiter ('ColumnDelimiter'))
For r = rLo To rHi
strData(r, c) = Space(cLen - cLens(r)) & strData(r, c)
Next r
Else ' all but the last row
For r = rLo To rHi
strData(r, c) = Space(cLen - cLens(r)) & strData(r, c) _
& ColumnDelimiter
Next r
End If
Next c
' Write the title to the print string ('PrintString').
Dim PrintString As String: PrintString = Title
' Append the data from the string array to the print string.
For r = rLo To rHi
PrintString = PrintString & RowDelimiter
For c = cLo To cHi
PrintString = PrintString & strData(r, c)
Next c
Next r
' Assign print string as the result.
GetDataString = PrintString
End Function
First you need to declare the data type of variables i and j
Dim i as Long
Dim j as Long
second, your array name V not A so correct this line
V(i, j) = Rnd * 50
finally, if your array contains numbers you can use this line
Debug.Print WorksheetFunction.Min(V)

Storing cell addresses into an array in vba while using a loop

I am trying to work through a code that utilizes a system to check two different worksheets by using a for loop and highlight the differences/edits made in the second sheet ("Version 2") onto the first sheet ("Original"). I have a feeling that I need to utilize an array but I'm not advanced enough where I know how to store the values and then later write them onto another sheet (down below).
I've gotten the code so that it highlights all the relevant cells, but now I'm trying to output it into a report (on another sheet called 'Logged Changes') which will summarize all the cell addresses where edits were made. Please forgive all the variables as this is from an old code set where variables are not explicitly defined:
Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer
o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0
Sheets("Original").Select
For i = 2 To p
For k = 1 To o
If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
Else
If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
End If
Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty
answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)
If answer = vbYes Then
If Sheet_Exists("Logged Changes") = False Then
Sheet_Name = "Logged Changes"
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
End If
Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
Unload Me
End If
End Sub
I have tried fiddling around with the code, but didn't want to clog it up with any unnecessary/broken lines. Any help would be greatly appreciated!
Try this:
Option Explicit
Private Sub CompareBasic()
Const SHT_REPORT As String = "Logged Changes"
Dim actSheet As Range
Dim c As Integer
Dim o As Long
Dim p As Long
Dim r As Long
Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
Dim arrUpdates
Set wsOrig = Worksheets("Original")
Set wsNew = Worksheets("Version 2")
o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
dataOrig = rngData.Value 'get an array of data
dataNew = wsNew.Range(rngData.Address).Value 'array of new data
ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
change = 0
For r = 1 To UBound(dataOrig, 1)
For c = 1 To UBound(dataOrig, 2)
v1 = dataOrig(r, c)
v2 = dataNew(r, c)
If Len(v1) > 0 Or Len(v2) > 0 Then
If IsNumeric(v1) Then
bDiff = v1 <> v2
Else
bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
End If
End If
'any difference?
If bDiff Then
change = change + 1
With rngData.Cells(r, c)
arrUpdates(change, 1) = .Address
.Interior.ColorIndex = 37
End With
arrUpdates(change, 2) = v1
arrUpdates(change, 3) = v2
End If
Next c
Next r
If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
With GetSheet(SHT_REPORT, ThisWorkbook)
.UsedRange.ClearContents
.Range("A1") = "Edited Requirements"
.Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
.Range("A4").Resize(change, 3).Value = arrUpdates
End With
Else
'Unload Me
End If
End Sub
'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
Dim rv As Worksheet
On Error Resume Next
Set rv = wb.Worksheets(wsName)
On Error GoTo 0
If rv Is Nothing Then
Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = "Logged Changes"
End If
Set GetSheet = rv
End Function
Sheet Differences
Option Explicit
Sub logChanges()
Const ws1Name As String = "Original"
Const ws2Name As String = "Version 2"
Const wsResult As String = "Logged Changes"
Const FirstRow As Long = 2
Const FirstColumn As Long = 1
Const LastRowColumn As Long = 1
Const LastColumnRow As Long = 2
Const ResultFirstCell As String = "A2"
Dim Headers As Variant
Headers = Array("Id", "Address", "Original", "Version 2")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
Dim LastColumn As Long
LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
.End(xlToLeft).Column
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
ws.Cells(LastRow, LastColumn))
Dim Data1 As Variant: Data1 = rng.Value
Set ws = wb.Worksheets(ws2Name)
Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
Dim Result() As Variant
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(Data1)
For j = 1 To UBound(Data1, 2)
If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
Next j
Next i
If k > 0 Then
transpose2D Result
On Error GoTo MissingResultSheet
Set ws = wb.Worksheets(wsResult)
On Error GoTo 0
ws.Range(ws.Range(ResultFirstCell), _
ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
MsgBox "Found '" & k & "' difference(s) in range '" _
& rng.Address(False, False) & "'.", vbInformation
Else
MsgBox "Found no differences in range '" _
& rng.Address(False, False) & "'.", vbExclamation
End If
Exit Sub
writeResult:
k = k + 1
ReDim Preserve Result(1 To 4, 1 To k)
Result(1, k) = k
Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
Result(3, k) = Data1(i, j)
Result(4, k) = Data2(i, j)
Return
MissingResultSheet:
If Err.Number = 9 Then
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = wsResult
If .Range(ResultFirstCell).Row > 1 Then
.Range(ResultFirstCell).Offset(-1) _
.Resize(, UBound(Headers) + 1).Value = Headers
End If
End With
Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
Else
'?
Exit Sub
End If
End Sub
Function getAddress(aRow As Long, aColumn As Long) As String
getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function
Sub transpose2D(ByRef Data As Variant)
Dim i As Long, j As Long
Dim Result As Variant
ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
LBound(Data) To UBound(Data))
For i = LBound(Data) To UBound(Data)
For j = LBound(Data, 2) To UBound(Data, 2)
Result(j, i) = Data(i, j)
Next j
Next i
Data = Result
End Sub
This solution for converting a column number to a string without using objects Function to convert column number to letter? could be used to write a descent getAddress function.

VBA - MsgBox a 2D Array (Matrix)

I am trying to visualize a 2D Matrix (Array) using a MsgBox, but the code I have doesn't give me the correct representation.
Sub test()
Dim M(22, 7) As Double
TwoD_Array_Matrix_In_MSGBOX (M)
End Sub
'_________________________________________________________________________
Public Function TwoD_Array_Matrix_In_MSGBOX(arr As Variant)
h = UBound(arr, 1)
w = UBound(arr, 2)
'MsgBox ("h = " & CStr(h + 1) & vbCrLf & "w = " & CStr(w + 1)) ' to check if the width and hight of the Matrix are correct
Dim msg As String
For i = 0 To w
For ii = 0 To h
msg = msg & arr(ii, i) & vbTab
Next ii
msg = msg & vbCrLf
Next i
MsgBox msg
End Function
This is the result I get:
You have w and h interchanged.
Dim msg As String
For i = 0 To h
For ii = 0 To w
msg = msg & arr(i, ii) & vbTab
Next ii
msg = msg & vbCrLf
Next i
MsgBox msg
this works perfectly for me
Private Sub this()
Dim this(22, 7) As Integer
Dim msg$
For i = LBound(this, 1) To UBound(this, 1)
For j = LBound(this, 2) To UBound(this, 2)
msg = msg & this(i, j) & vbTab
Next j
Next i
MsgBox msg
End Sub
It might be more flexible to write a function which returns a string, a sort of 2-dimensional join, which allows you to choose both the item delimiter (defaulting to vbTab) and the row delimiter (defaulting to vbCrLf).
You can MsgBox this string -- or write it to the immediate window -- or (with a comma chosen as one of the delimiters) -- write it to a CSV file, etc.:
Function MatrixJoin(M As Variant, Optional delim1 As String = vbTab, Optional delim2 As String = vbCrLf) As String
Dim i As Long, j As Long
Dim row As Variant, rows As Variant
ReDim rows(LBound(M, 1) To UBound(M, 1))
ReDim row(LBound(M, 2) To UBound(M, 2))
For i = LBound(M, 1) To UBound(M, 1)
For j = LBound(M, 2) To UBound(M, 2)
row(j) = M(i, j)
Next j
rows(i) = Join(row, delim1)
Next i
MatrixJoin = Join(rows, delim2)
End Function
Tested by:
Sub test()
Dim A As Variant
A = Range("A1:B3").Value
MsgBox MatrixJoin(A)
Debug.Print MatrixJoin(A, ",", ";")
End Sub
Screenshots of output:

is it possbile to create an collection of arrays in vba?

first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function

VBA array sort function?

I'm looking for a decent sort implementation for arrays in VBA. A Quicksort would be preferred. Or any other sort algorithm other than bubble or merge would suffice.
Please note that this is to work with MS Project 2003, so should avoid any of the Excel native functions and anything .net related.
Take a look here:
Edit: The referenced source (allexperts.com) has since closed, but here are the relevant author comments:
There are many algorithms available on the web for sorting. The most versatile and usually the quickest is the Quicksort algorithm. Below is a function for it.
Call it simply by passing an array of values (string or numeric; it doesn't matter) with the Lower Array Boundary (usually 0) and the Upper Array Boundary (i.e. UBound(myArray).)
Example: Call QuickSort(myArray, 0, UBound(myArray))
When it's done, myArray will be sorted and you can do what you want with it.
(Source: archive.org)
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
Note that this only works with single-dimensional (aka "normal"?) arrays. (There's a working multi-dimensional array QuickSort here.)
I converted the 'fast quick sort' algorithm to VBA, if anyone else wants it.
I have it optimized to run on an array of Int/Longs but it should be simple to convert it to one that works on arbitrary comparable elements.
Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
Dim M As Long, i As Long, j As Long, v As Long
M = 4
If ((r - l) > M) Then
i = (r + l) / 2
If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
If (a(l) > a(r)) Then swap a, l, r
If (a(i) > a(r)) Then swap a, i, r
j = r - 1
swap a, i, j
i = l
v = a(j)
Do
Do: i = i + 1: Loop While (a(i) < v)
Do: j = j - 1: Loop While (a(j) > v)
If (j < i) Then Exit Do
swap a, i, j
Loop
swap a, i, r - 1
QuickSort a, l, j
QuickSort a, i + 1, r
End If
End Sub
Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
Dim T As Long
T = a(i)
a(i) = a(j)
a(j) = T
End Sub
Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
Dim i As Long, j As Long, v As Long
For i = lo0 + 1 To hi0
v = a(i)
j = i
Do While j > lo0
If Not a(j - 1) > v Then Exit Do
a(j) = a(j - 1)
j = j - 1
Loop
a(j) = v
Next i
End Sub
Public Sub sort(ByRef a() As Long)
QuickSort a, LBound(a), UBound(a)
InsertionSort a, LBound(a), UBound(a)
End Sub
Dim arr As Object
Dim InputArray
'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")
'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")
'number
'InputArray = Array(6, 5, 3, 4, 2, 1)
' adding the elements in the array to array_list
For Each element In InputArray
arr.Add element
Next
'sorting happens
arr.Sort
'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.
sorted_array = arr.toarray
Explanation in German but the code is a well-tested in-place implementation:
Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
Dim P1 As Long, P2 As Long, Ref As String, TEMP As String
P1 = LB
P2 = UB
Ref = Field((P1 + P2) / 2)
Do
Do While (Field(P1) < Ref)
P1 = P1 + 1
Loop
Do While (Field(P2) > Ref)
P2 = P2 - 1
Loop
If P1 <= P2 Then
TEMP = Field(P1)
Field(P1) = Field(P2)
Field(P2) = TEMP
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If LB < P2 Then Call QuickSort(Field, LB, P2)
If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub
Invoked like this:
Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))
Natural Number (Strings) Quick Sort
Just to pile onto the topic.
Normally, if you sort strings with numbers you'll get something like this:
Text1
Text10
Text100
Text11
Text2
Text20
But you really want it to recognize the numerical values and be sorted like
Text1
Text2
Text10
Text11
Text20
Text100
Here's how to do it...
Note:
I stole the Quick Sort from the internet a long time ago, not sure where now...
I translated the CompareNaturalNum function which was originally written in C from the internet as well.
Difference from other Q-Sorts: I don't swap the values if the BottomTemp = TopTemp
Natural Number Quick Sort
Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer
intBottomTemp = intBottom
intTopTemp = intTop
strPivot = strArray((intBottom + intTop) \ 2)
Do While (intBottomTemp <= intTopTemp)
' < comparison of the values is a descending sort
Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
intBottomTemp = intBottomTemp + 1
Loop
Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
intTopTemp = intTopTemp - 1
Loop
If intBottomTemp < intTopTemp Then
strTemp = strArray(intBottomTemp)
strArray(intBottomTemp) = strArray(intTopTemp)
strArray(intTopTemp) = strTemp
End If
If intBottomTemp <= intTopTemp Then
intBottomTemp = intBottomTemp + 1
intTopTemp = intTopTemp - 1
End If
Loop
'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub
Natural Number Compare(Used in Quick Sort)
Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer
If Not (IsNull(string1) Or IsNull(string2)) Then
iPos1 = 1
iPos2 = 1
Do While iPos1 <= Len(string1)
If iPos2 > Len(string2) Then
CompareNaturalNum = 1
Exit Function
End If
If isDigit(string1, iPos1) Then
If Not isDigit(string2, iPos2) Then
CompareNaturalNum = -1
Exit Function
End If
iPosOrig1 = iPos1
iPosOrig2 = iPos2
Do While isDigit(string1, iPos1)
iPos1 = iPos1 + 1
Loop
Do While isDigit(string2, iPos2)
iPos2 = iPos2 + 1
Loop
nOffset1 = (iPos1 - iPosOrig1)
nOffset2 = (iPos2 - iPosOrig2)
n1 = Val(Mid(string1, iPosOrig1, nOffset1))
n2 = Val(Mid(string2, iPosOrig2, nOffset2))
If (n1 < n2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (n1 > n2) Then
CompareNaturalNum = 1
Exit Function
End If
' front padded zeros (put 01 before 1)
If (n1 = n2) Then
If (nOffset1 > nOffset2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (nOffset1 < nOffset2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
ElseIf isDigit(string2, iPos2) Then
CompareNaturalNum = 1
Exit Function
Else
If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
CompareNaturalNum = -1
Exit Function
ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
CompareNaturalNum = 1
Exit Function
End If
iPos1 = iPos1 + 1
iPos2 = iPos2 + 1
End If
Loop
' Everything was the same so far, check if Len(string2) > Len(String1)
' If so, then string1 < string2
If Len(string2) > Len(string1) Then
CompareNaturalNum = -1
Exit Function
End If
Else
If IsNull(string1) And Not IsNull(string2) Then
CompareNaturalNum = -1
Exit Function
ElseIf IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 0
Exit Function
ElseIf Not IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
End Function
isDigit(Used in CompareNaturalNum)
Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
If pos <= Len(str) Then
iCode = Asc(Mid(str, pos, 1))
If iCode >= 48 And iCode <= 57 Then isDigit = True
End If
End Function
I posted some code in answer to a related question on StackOverflow:
Sorting a multidimensionnal array in VBA
The code samples in that thread include:
A vector array Quicksort;
A multi-column array QuickSort;
A BubbleSort.
Alain's optimised Quicksort is very shiny: I just did a basic split-and-recurse, but the code sample above has a 'gating' function that cuts down on redundant comparisons of duplicated values. On the other hand, I code for Excel, and there's a bit more in the way of defensive coding - be warned, you'll need it if your array contains the pernicious 'Empty()' variant, which will break your While... Wend comparison operators and trap your code in an infinite loop.
Note that quicksort algorthms - and any recursive algorithm - can fill the stack and crash Excel. If your array has fewer than 1024 members, I'd use a rudimentary BubbleSort.
Public Sub QuickSortArray(ByRef SortArray As Variant, _
Optional lngMin As Long = -1, _
Optional lngMax As Long = -1, _
Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf varType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf varType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub
I wonder what would you say about this array sorting code. It's quick for implementation and does the job ... haven't tested for large arrays yet. It works for one-dimensional arrays, for multidimensional additional values re-location matrix would need to be build (with one less dimension that the initial array).
For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
eValue = eArray(AR1)
For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
If eArray(AR2) < eValue Then
eArray(AR1) = eArray(AR2)
eArray(AR2) = eValue
eValue = eArray(AR1)
End If
Next AR2
Next AR1
You didn't want an Excel-based solution but since I had the same problem today and wanted to test using other Office Applications functions I wrote the function below.
Limitations:
2-dimensional arrays;
maximum of 3 columns as sort keys;
depends on Excel;
Tested calling Excel 2010 from Visio 2010
Option Base 1
Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")
' Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library
Dim excel_application As Excel.Application
Dim excel_workbook As Excel.Workbook
Dim excel_worksheet As Excel.Worksheet
Set excel_application = CreateObject("Excel.Application")
excel_application.Visible = True
excel_application.ScreenUpdating = False
excel_application.WindowState = xlNormal
Set excel_workbook = excel_application.Workbooks.Add
excel_workbook.Activate
Set excel_worksheet = excel_workbook.Worksheets.Add
excel_worksheet.Activate
excel_worksheet.Visible = xlSheetVisible
Dim excel_range As Excel.Range
Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
excel_range = array_2D
For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)
If IsNumeric(array_sortkeys(i_sortkey)) Then
sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)
Else
MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
End
End If
Next i_sortkey
For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
Select Case LCase(array_sortorders(i_sortorder))
Case "asc"
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
Case "desc"
array_sortorders(i_sortorder) = XlSortOrder.xlDescending
Case Else
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
End Select
Next i_sortorder
Select Case LCase(tag_header)
Case "yes"
tag_header = Excel.xlYes
Case "no"
tag_header = Excel.xlNo
Case "guess"
tag_header = Excel.xlGuess
Case Else
tag_header = Excel.xlGuess
End Select
Select Case LCase(tag_matchcase)
Case "true"
tag_matchcase = True
Case "false"
tag_matchcase = False
Case Else
tag_matchcase = False
End Select
Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
Case 1
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
Case 2
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
Case 3
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
Case Else
MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
End
End Select
For i_row = 1 To excel_range.Rows.Count
For i_column = 1 To excel_range.Columns.Count
array_2D(i_row, i_column) = excel_range(i_row, i_column)
Next i_column
Next i_row
excel_workbook.Close False
excel_application.Quit
Set excel_worksheet = Nothing
Set excel_workbook = Nothing
Set excel_application = Nothing
sort_array_2D_excel = array_2D
End Function
This is an example on how to test the function:
Private Sub test_sort()
array_unsorted = dim_sort_array()
Call msgbox_array(array_unsorted)
array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")
Call msgbox_array(array_sorted)
End Sub
Private Function dim_sort_array()
Dim array_unsorted(1 To 5, 1 To 3) As String
i_row = 0
i_row = i_row + 1
array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"
i_row = i_row + 1
array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
dim_sort_array = array_unsorted
End Function
Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")
msgbox_string = string_info & vbLf
For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)
msgbox_string = msgbox_string & vbLf & i_row & vbTab
For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)
msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab
Next i_column
Next i_row
MsgBox msgbox_string
End Sub
If anybody tests this using other versions of office please post here if there are any problems.
Heapsort implementation. An O(n log(n)) (both average and worst case), in place, unstable sorting algorithm.
Use with: Call HeapSort(A), where A is a one dimensional array of variants, with Option Base 1.
Sub SiftUp(A() As Variant, I As Long)
Dim K As Long, P As Long, S As Variant
K = I
While K > 1
P = K \ 2
If A(K) > A(P) Then
S = A(P): A(P) = A(K): A(K) = S
K = P
Else
Exit Sub
End If
Wend
End Sub
Sub SiftDown(A() As Variant, I As Long)
Dim K As Long, L As Long, S As Variant
K = 1
Do
L = K + K
If L > I Then Exit Sub
If L + 1 <= I Then
If A(L + 1) > A(L) Then L = L + 1
End If
If A(K) < A(L) Then
S = A(K): A(K) = A(L): A(L) = S
K = L
Else
Exit Sub
End If
Loop
End Sub
Sub HeapSort(A() As Variant)
Dim N As Long, I As Long, S As Variant
N = UBound(A)
For I = 2 To N
Call SiftUp(A, I)
Next I
For I = N To 2 Step -1
S = A(I): A(I) = A(1): A(1) = S
Call SiftDown(A, I - 1)
Next
End Sub
#Prasand Kumar, here's a complete sort routine based on Prasand's concepts:
Public Sub ArrayListSort(ByRef SortArray As Variant)
'
'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
'data-type.
'
'AUTHOR: Peter Straton
'
'CREDIT: Derived from Prasand Kumar's post at: https://stackoverflow.com/questions/152319/vba-array-sort-function
'
'*************************************************************************************************************
Static ArrayListObj As Object
Dim i As Long
Dim LBnd As Long
Dim UBnd As Long
LBnd = LBound(SortArray)
UBnd = UBound(SortArray)
'If necessary, create the ArrayList object, to be used to sort the specified array's values
If ArrayListObj Is Nothing Then
Set ArrayListObj = CreateObject("System.Collections.ArrayList")
Else
ArrayListObj.Clear 'Already allocated so just clear any old contents
End If
'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
'using a single assignment statement.)
For i = LBnd To UBnd
ArrayListObj.Add SortArray(i)
Next i
ArrayListObj.Sort 'Do the sort
'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
'statement. But the result is always zero-based so then, if necessary, adjust the resulting array to match
'its original index base.
SortArray = ArrayListObj.ToArray
If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub
Somewhat related, but I was also looking for a native excel VBA solution since advanced data structures (Dictionaries, etc.) aren't working in my environment. The following implements sorting via a binary tree in VBA:
Assumes array is populated one by one
Removes duplicates
Returns a separated string ("0|2|3|4|9") which can then be split.
I used it for returning a raw sorted enumeration of rows selected for an arbitrarily selected range
Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
If CenterType = tEMPTY Then
Center = x
CenterType = tValue
ElseIf x > Center Then
If RightType = tEMPTY Then
Right = x
RightType = tValue
ElseIf RightType = tTree Then
Right.Add x
ElseIf x <> Right Then
curLeaf = Right
Set Right = New TreeList
Right.Add curLeaf
Right.Add x
RightType = tTree
End If
ElseIf x < Center Then
If LeftType = tEMPTY Then
Left = x
LeftType = tValue
ElseIf LeftType = tTree Then
Left.Add x
ElseIf x <> Left Then
curLeaf = Left
Set Left = New TreeList
Left.Add curLeaf
Left.Add x
LeftType = tTree
End If
End If
End Sub
Public Function GetList$()
Const sep$ = "|"
If LeftType = tValue Then
LeftList$ = Left & sep
ElseIf LeftType = tTree Then
LeftList = Left.GetList & sep
End If
If RightType = tValue Then
RightList$ = sep & Right
ElseIf RightType = tTree Then
RightList = sep & Right.GetList
End If
GetList = LeftList & Center & RightList
End Function
'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")
I think my code (tested) is more "educated", assuming the simpler the better.
Option Base 1
'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
Dim check As Boolean
check = True
If IsNull(Rango) Then
check = False
End If
If check Then
Application.Volatile
Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
ReDim x(n, m)
For i = 1 To n Step 1
For j = 1 To m Step 1
x(i, j) = Application.Large(Rango, k)
k = k - 1
Next j
Next i
SORT = x
Else
Exit Function
End If
End Function
This is what I use to sort in memory - it can easily be expanded to sort an array.
Sub sortlist()
Dim xarr As Variant
Dim yarr As Variant
Dim zarr As Variant
xarr = Sheets("sheet").Range("sing col range")
ReDim yarr(1 To UBound(xarr), 1 To 1)
ReDim zarr(1 To UBound(xarr), 1 To 1)
For n = 1 To UBound(xarr)
zarr(n, 1) = 1
Next n
For n = 1 To UBound(xarr) - 1
y = zarr(n, 1)
For a = n + 1 To UBound(xarr)
If xarr(n, 1) > xarr(a, 1) Then
y = y + 1
Else
zarr(a, 1) = zarr(a, 1) + 1
End If
Next a
yarr(y, 1) = xarr(n, 1)
Next n
y = zarr(UBound(xarr), 1)
yarr(y, 1) = xarr(UBound(xarr), 1)
yrng = "A1:A" & UBound(yarr)
Sheets("sheet").Range(yrng) = yarr
End Sub

Resources