VBA Snippets


Array_1Dimensional

Checks if an array is one dimensional.
Public Function Array_1Dimensional( _
ByVal vArray As Variant) As Boolean

Const sPROCNAME As String = "Array_1Dimensional"
Dim lUpper As Long
On Error GoTo ErrorHandler

lUpper = UBound(vArray, 2)
Array_1Dimensional = False
Exit Function

ErrorHandler:
Array_1Dimensional = True
End Function

Array_2ArraysAddMulti

Adds the values from two multi dimensional arrays and returns the multi dimensional array containing the sum of the corresponding values.
Public Function Array_2ArraysAddMulti( _
ByVal sArray1Name As String, _
ByVal vArrayName1 As Variant, _
ByVal sArray2Name As String, _
ByVal vArrayName2 As Variant, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1) As Variant

Const sPROCNAME As String = "Array_2ArraysAddMulti"
Dim varraynamesum As Variant
Dim lrowcount As Long
Dim icolumncount As Integer
On Error GoTo ErrorHandler

If lLower = -1 Then lLower = LBound(vArrayName1, 1)
If lUpper = -1 Then lUpper = UBound(vArrayName1, 1)
ReDim varraynamesum(lUpper, UBound(vArrayName1, 2))
If UBound(vArrayName1) = UBound(vArrayName2) Then

For lrowcount = lLower To lUpper
For icolumncount = LBound(vArrayName1, 2) To UBound(vArrayName1, 2)
varraynamesum(lrowcount, icolumncount) = _
vArrayName1(lrowcount, icolumncount) + _
vArrayName2(lrowcount, icolumncount)

Next icolumncount
Next lrowcount
End If
Array_2ArraysAddMulti = varraynamesum

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_2ArraysAddMulti = vArrayName1
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"combine the two multi-dimensional arrays " & _
"""" & sArray1Name & """ and """ & sArray2Name & """" & _
vbCrLf & "and return the array of a larger dimension")
End Function

Array_2ArraysAddSingle

Adds the values from two single dimensional arrays and returns the single dimensional array containing the sum of the corresponding values.
Public Function Array_2ArraysAddSingle( _
ByVal sArray1Name As String, _
ByVal vArrayName1 As Variant, _
ByVal sArray2Name As String, _
ByVal vArrayName2 As Variant, _
Optional ByVal llower As Long = -1, _
Optional ByVal lupper As Long = -1) As Variant

Const sPROCNAME As String = "Array_2ArraysAddSingle"
Dim lrowcount As Long
Dim vArrayNameSum As Variant
On Error GoTo ErrorHandler

If llower = -1 Then llower = LBound(vArrayName1)
If lupper = -1 Then lupper = UBound(vArrayName1)
ReDim vArrayNameSum(lupper)
If lupper = UBound(vArrayName2) Then
For lrowcount = llower To lupper
vArrayNameSum(lrowcount) = vArrayName1(lrowcount) + vArrayName2(lrowcount)
Next lrowcount
End If
Array_Add2ArraysSingle = vArrayNameSum

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_2ArraysAddSingle = vArrayName1
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"combine the two single dimensional arrays " & _
"""" & sArray1Name & """ and """ & sArray2Name & """" & _
vbCrLf & "and return the array of a larger dimension")
End Function

Array_2ArraysDeleteMulti

Public Function Array_2ArraysDeleteMulti( _
ByVal sArray1Name As String, _
ByVal vArrayName1 As Variant, _
ByVal sArray2Name As String, _
ByVal vArrayName2 As Variant, _
Optional ByVal llower As Long = -1, _
Optional ByVal lupper As Long = -1) As Variant

Const sPROCNAME As String = "Array_2ArraysDeleteMulti"
Dim lrowcount As Long
Dim vArrayNameSum As Variant
On Error GoTo ErrorHandler

Array_2ArraysDeleteMulti = vArrayNameSum

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_2ArraysDeleteMulti = vArrayName1
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description,
"combine the two multi dimensional arrays " & _
"""" & sArray1Name & """ and """ & sArray2Name & """" & _
vbCrLf & "and return the array of a larger dimension")
End Function

Array_AddToItMulti

Adds an element to the end of a multi dimensional array. The last dimension of the array is increased if necessary. The slightly larger multi dimensional array is returned.
Public Function Array_AddToItMulti( _
ByVal sText As String, _
ByVal bNeworExisting As Boolean, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal iAddCol As Integer = 1, _
Optional ByVal iTotalDimensions As Integer = 1) As Variant

Const sPROCNAME As String = "Array_AddToItMulti"
Dim lupperbound As Long
On Error GoTo ErrorHandler

If IsEmpty(vArrayName) = True Then
ReDim vArrayName(iTotalDimensions, 1)
vArrayName(iAddCol, 1) = sText
Else
If bNeworExisting = True Then
lupperbound = UBound(vArrayName, 2)
If IsEmpty(vArrayName(iTotalDimensions, UBound(vArrayName, 2))) = False Then _
ReDim Preserve vArrayName(iTotalDimensions, lupperbound + 1)
If lRowNo = 0 Then vArrayName(iAddCol, lupperbound + 1) = sText
If lRowNo > 0 Then vArrayName(iAddCol, lRowNo) = sText
Else
If lRowNo = 0 Then vArrayName(iAddCol, UBound(vArrayName, 2)) = sText
If lRowNo > 0 Then vArrayName(iAddCol, lRowNo) = sText
End If
End If
Array_AddToItMulti = vArrayName

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"add the entry """ & sText & """ to the multi dimensional array " & _
"""" & sArrayName & """" & " in column """ & iAddCol & """")
End Function

Array_AddToItSingle

Adds an element to the end of a single dimensional array. The dimension of the array is increased if necessary. The slightly larger single dimensional array is returned.
Public Function Array_AddToItSingle( _
ByVal sText As String, _
ByVal bNeworExisting As Boolean, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal iTotalDimensions As Integer = 1) As Variant

Const sPROCNAME As String = "Array_AddToItSingle"
Dim lupperbound As Long
On Error GoTo ErrorHandler

If IsEmpty(vArrayName) = True Then
ReDim vArrayName(iTotalDimensions)
vArrayName(1) = sText
Else
If bNeworExisting = True Then
lupperbound = UBound(vArrayName)
If IsEmpty(vArrayName(iTotalDimensions)) = False Then _
ReDim Preserve vArrayName(iTotalDimensions, lupperbound + 1)
If lRowNo = 0 Then vArrayName(lupperbound + 1) = sText
If lRowNo > 0 Then vArrayName(lRowNo) = sText
Else
If lRowNo = 0 Then vArrayName(UBound(vArrayName)) = sText
If lRowNo > 0 Then vArrayName(lRowNo) = sText
End If
End If
Array_AddToItSingle = vArrayName

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"add the entry """ & sText & """ to the single dimensional array " & _
"""" & sArrayName & """")
End Function

Array_Check

Checks if an array that has been assigned to a Variant datatype actually contains any data or not. Returns True or False.
Public Function Array_Check( _
ByVal vArrayName As Variant, _
Optional ByVal bMulti As Boolean = False, _
Optional ByVal iBase As Integer = 0) As Boolean

Const sPROCNAME As String = "Array_Check"
Dim stextstring As String
On Error GoTo ErrorHandler

If bMulti = True Then stextstring = vArrayName(iBase, iBase)
If bMulti = False Then stextstring = vArrayName(iBase)
Array_Check = True

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_Check = False
End Function

Array_Concatenate2Multi

Concatenates two multi dimensional arrays into one and returns the multi dimensional array containing the concatenation of the corresponding elements. You can also prefix or suffix strings to every entry after the entries have been concatenated.
Public Function Array_Concatenate2Multi( _
ByVal sArrayName1 As String, _
ByVal vArrayName1 As Variant, _
ByVal sArrayName2 As String, _
ByVal vArrayName2 As Variant, _
Optional ByVal sBefore As String = "", _
Optional ByVal sMiddle As String = "", _
Optional ByVal sAfter As String = "") As Variant

Const sPROCNAME As String = "Array_Concatenate2Multi"
On Error GoTo ErrorHandler


If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Function

Array_Concatenate2Single

Concatenates two single dimensional arrays into one and returns the single dimensional array containing the concatenation of the corresponding elements. You can also prefix or suffix strings to every entry after the entries have been concatenated.
Public Function Array_Concatenate2Single( _
ByVal sArrayName1 As String, _
ByVal vArrayName1 As Variant, _
ByVal sArrayName2 As String, _
ByVal vArrayName2 As Variant, _
Optional ByVal sBefore As String = "", _
Optional ByVal sMiddle As String = "", _
Optional ByVal sAfter As String = "") As Variant

Const sPROCNAME As String = "Array_Concatenate2Single"
Dim larraycount As Long
On Error GoTo ErrorHandler

If UBound(vArrayName1) = UBound(vArrayName2) Then
For larraycount = 1 To UBound(vArrayName1)
vArrayName1(larraycount) = sBefore & vArrayName1(larraycount) & _
sMiddle & vArrayName2(larraycount) & sAfter
Next larraycount
End If
Array_Concatenate2Single = vArrayName1

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"combine the two single dimensional arrays " & _
"""" & sArrayName1 & """ and """ & sArrayName2 & """ with :" & vbCrLf & _
"""" & sBefore & """ before the final array" & vbCrLf & _
"""" & sMiddle & """ between the two arrays" & vbCrLf & _
"""" & sAfter & """ after the final array")
End Function

Array_ContainsData

Public Function Array_ContainsData( _
ByVal vArray As Variant) As Boolean

Const sPROCNAME As String = "Array_ContainsData"
Dim lUpper As Long
On Error GoTo ErrorHandler

lUpper = UBound(vArray)
Array_ContainsData = True

Exit Function
ErrorHandler:
Array_ContainsData = False
End Function

Array_CountMultiple

Public Sub Array_CountMultiple
End Sub

return the number of items in a multi dimensional array

Array_CountMultipleMatch

Returns the total number of rows in a multi dimensional array that match a particular string or value in a given column Needs changing to a multi dimensional array !!!!!.
Public Function Array_CountEntriesMultiple( _
ByVal sArrayname As String, _
ByVal vArrayName As Variant, _
ByVal sText As String, _
Optional ByVal iCountCol As Integer = 1, _
Optional ByVal bIgnoreBrackets As Boolean = False) As Integer

Const sPROCNAME As String = "Array_CountEntriesMultiple"
Dim larraycount As Long
Dim lnooftimes As Long
Dim iopenbracketpos As Integer
On Error GoTo ErrorHandler

lnooftimes = 0
For larraycount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
If bIgnoreBrackets = True Then
iopenbracketpos = InStr(1, vArrayName(larraycount), "(")
If Left(vArrayName(larraycount), iopenbracketpos - 1) = sText Then _
lnooftimes = lnooftimes + 1
Else
If vArrayName(iCountCol, larraycount) = sText Then lnooftimes = lnooftimes + 1
End If
Next larraycount
Array_CountEntriesMultiple = lnooftimes

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"count the total number of entires in the multidimensional array " & _
"""" & sArrayname & """" & vbCrLf & _
"that match """ & sText & """ in column """ & iCountCol & """")
End Function

Array_CountSingle

Return the number of items in a single dimensional array.
Sub Array_CountSingle()
End Sub

Array_FindRowMatching

Public Function Array_FindRowMatching( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sFindValue As String, _
ByVal iLookInCol As Integer, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1) As Long

Const sPROCNAME As String = "Array_FindRowMatching"
Dim larraycount As Long
On Error GoTo ErrorHandler

If lLower = -1 Then lLower = LBound(vArrayName, 2)
If lUpper = -1 Then lUpper = UBound(vArrayName, 2)
For larraycount = lLower To lUpper
If vArrayName(larraycount, iLookInCol) = sFindValue Then
Exit For
End If
Next larraycount

Array_FindRowMatching = larraycount

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Array_FindStrMatching

Public Function Array_FindStrMatching( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sFindValue As String, _
ByVal iLookInCol As Integer, _
ByVal iReturnCol As Integer, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1) As String

Const sPROCNAME As String = "Array_FindStrMatching"
Dim larraycount As Long
On Error GoTo ErrorHandler

If lLower = -1 Then lLower = LBound(vArrayName, 2)
If lUpper = -1 Then lUpper = UBound(vArrayName, 2)
For larraycount = lLower To lUpper
If vArrayName(larraycount, iLookInCol) = sFindValue Then Exit For
Next larraycount
Array_FindStrMatching = vArrayName(larraycount, iReturnCol)

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Array_IsMulti

Public Function Array_IsMulti( _
ByVal vArrayName As Variant) As Boolean

Const sPROCNAME As String = "Array_FindRowMatching"
Dim sValue As String
On Error GoTo ErrorHandler

sValue = vArrayName(1, 1)
Array_IsMulti = True
Exit Function

ErrorHandler:
Array_IsMulti = False
End Function

Array_IsNothing

Public Function Array_IsNothing( _
ByVal vArrayName As Variant) As Boolean

Const sPROCNAME As String = "Array_IsNothing"
On Error Goto ErrorHandler

Array_IsNothing = False
If vArrayName Is Nothing Then
Array_IsNothing = True
End If

ErrorHandler:

End Function

Array_ItemExists

Public Function Array_ItemExists( _
ByVal vStringArray As Variant, _
ByVal sItemToFind As String) As Boolean

Const sPROCNAME As String = "Array_ItemExists"
Dim icount As Integer
Dim bfound As Boolean
On Error GoTo ErrorHandler

bfound = False
For icount = 0 To UBound(vStringArray)
If (vStringArray(icount) = sItemToFind) Then
bfound = True
Exit For
End If
Next icount
Array_ItemExists = bfound

Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Array_ItemExistsInMulti

Determines if an entry exists in a multi dimensional array in a particular column. Returns True or False.
Public Function Array_ExistsMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal vText As Variant, _
Optional ByVal iDimension As Integer = 1) As Boolean

Const sPROCNAME As String = "Array_ExistsMulti"
Dim larraycount As Long
Dim binthearray As Boolean
On Error GoTo ErrorHandler

binthearray = False
If (vArrayName(1, 1) <> "") Then
If (vText = Empty) Then
vText = "blank"
End If
For larraycount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
If (vText = (vArrayName(larraycount, iDimension))) Then
binthearray = True
End If
Next larraycount
End If
Array_ExistsMulti = binthearray

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_ExistsMulti = False
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the entry """ & CStr(vText) & """ exists in the column """ & _
iDimension & """ of the multi dimensional array """ & sArrayName & """")
End Function

Array_ItemExistsInSingle

Public Function Array_ExistsSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sText As String, _
Optional ByVal bIgnoreBrackets As Boolean = False) As Boolean

Const sPROCNAME As String = "Array_ExistsSingle"
Dim scurrenttext As String
Dim iopenbracketpos As Integer
Dim larraycount As Long
On Error GoTo ErrorHandler

For larraycount = LBound(vArrayName) To UBound(vArrayName)
If bIgnoreBrackets = True Then
iopenbracketpos = InStr(1, vArrayName(larraycount), "(")
If Left(vArrayName(larraycount), iopenbracketpos - 1) = sText Then
Array_ExistsSingle = True
Exit Function
End If
Else
If vArrayName(larraycount) = sText Then
Array_ExistsSingle = True
Exit Function
End If
End If
Next larraycount
Array_ExistsSingle = False

If gbDEBUG = False Then Exit Function
ErrorHandler:
Array_ExistsSingle = False
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the entry """ & CStr(vText) & """ exists in the " & _
"single dimensional array """ & sArrayName & """")
End Function

Array_ItemRemove

Public Function Array_ItemRemove(ByVal myArray As Variant, _ 
ByVal iIndexNo As Integer) As Variant
Dim i As Integer

For i = iIndexNo + 1 To UBound(myArray)
myArray(i - 1) = myArray(i)
Next i
ReDim Preserve myArray(UBound(myArray) - 1)
Array_ItemRemove = myArray
End Function

Array_Redim2

Public Function Array_Redim2( _
ByVal vaArrayName As Variant, _
ByVal lUpper1 As Long, _
ByVal lUpper2 As Long, _
Optional ByVal iBaseValue As Integer = 1) As Variant

Const sPROCNAME As String = "Array_Redim2"

if iBaseValue = 0 Then ReDim vaArrayName(lUpper1, lUpper2)
If iBaseValue = 1 Then ReDim vaArrayName(1 To lUpper1, 1 To lUpper2)

Array_Redim2 = vaArrayName
End Function

Array_RemoveAfterCharMulti

Removes any text found after the first occurance of a particular character from all the entries in a multi dimensional array TEST !!!.
Public Function Array_RemoveAfterCharMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sChar As String) _
As Variant

Dim larraycount As Long
Dim icharpos As Integer
On Error GoTo AnError

' WHAT IF THERE IS NO CHARACTER FOUND ??

For larraycount = 1 To UBound(vArrayName) - 1
icharpos = InStr(1, vArrayName(larraycount), sChar)
vArrayName(larraycount) = Left$(vArrayName(larraycount), icharpos - 1)
Next larraycount

Array_RemoveAfterCharMulti = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveAfterCharMulti", msMODULENAME, 1, _
"remove any text found after character """ & sChar & """" & _
" from the entries in the multi dimensional array """ & sArrayName & """")
End Function

Array_RemoveAfterCharSingle

Removes any text found after the first occurance of a particular character from all the entries in a single dimensional array TEST !!!.
Public Function Array_RemoveAfterCharSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sChar As String) _
As Variant

Dim iarraycount As Integer
Dim iopenbracketpos As Integer
On Error GoTo AnError

' WHAT IF THERE IS NO OPEN BRACKET FOUND ???

For iarraycount = 1 To UBound(vArrayName) - 1
iopenbracketpos = InStr(1, vArrayName(iarraycount), "(")
vArrayName(iarraycount) = Left(vArrayName(iarraycount), iopenbracketpos - 1)
Next iarraycount

Array_RemoveAfterCharSingle = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveAfterCharSingle", msMODULENAME, 1, _
"remove any text found after character """ & sChar & """" & _
" from the entries in the single dimensional array """ & sArrayName & """")
End Function

Array_RemoveCriteriaMulti

Removes all the entries from a multi dimensional array that match a particular criteria, in a given column. Normally used for filtering on numerical data. The slightly smaller multi dimensional array is returned.
Public Function Array_RemoveCriteriaMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal iSearchCol As Integer, _
ByVal vCompare As Variant, _
Optional ByVal sCondition As String = "=") _
As Variant

Dim vArrayNameTemp As Variant
Dim lequalcount As Long
Dim lnotequalcount As Long
Dim larrayupper As Long
Dim larraycount1 As Long
Dim larraycount2 As Long
Dim baddelement As Boolean
Dim lmatches As Long

On Error GoTo AnError
lmatches = 0
For larraycount1 = UBound(vArrayName, 1) To LBound(vArrayName, 1) Step -1
baddelement = False
If sCondition = "=" Then _
If vArrayName(larraycount1, iSearchCol) = vCompare Then baddelement = True
If sCondition = "<>" Then _
If vArrayName(larraycount1, iSearchCol) <> vCompare Then baddelement = True
If sCondition = ">" Then _
If vArrayName(larraycount1, iSearchCol) > vCompare Then baddelement = True
If sCondition = ">=" Then _
If vArrayName(larraycount1, iSearchCol) >= vCompare Then baddelement = True
If sCondition = "<" Then _
If vArrayName(larraycount1, iSearchCol) < vCompare Then baddelement = True
If sCondition = "<=" Then _
If vArrayName(larraycount1, iSearchCol) <= vCompare Then baddelement = True

If baddelement = True Then lmatches = lmatches + 1
Next larraycount1

ReDim vArrayNameTemp(lmatches, UBound(vArrayName, 2))
lmatches = 1
For larraycount1 = LBound(vArrayName, 1) To UBound(vArrayName, 1)
baddelement = False
If sCondition = "=" Then _
If vArrayName(larraycount1, iSearchCol) <> vCompare Then baddelement = True
If sCondition = "<>" Then _
If vArrayName(larraycount1, iSearchCol) = vCompare Then baddelement = True
If sCondition = ">" Then _
If vArrayName(larraycount1, iSearchCol) > vCompare Then baddelement = True
If sCondition = ">=" Then _
If vArrayName(larraycount1, iSearchCol) >= vCompare Then baddelement = True
If sCondition = "<" Then _
If vArrayName(larraycount1, iSearchCol) < vCompare Then baddelement = True
If sCondition = "<=" Then _
If vArrayName(larraycount1, iSearchCol) <= vCompare Then baddelement = True

If baddelement = True Then
For larraycount2 = LBound(vArrayName, 2) To UBound(vArrayName, 2)
vArrayNameTemp(lmatches, larraycount2) = vArrayName(larraycount1, larraycount2)
Next larraycount2
lmatches = lmatches + 1
End If
Next larraycount1
Array_RemoveCriteriaMulti = vArrayNameTemp

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveCriteriaMulti", msMODULENAME, 1, _
"remove all the rows in the multi dimensional array """ & sArrayName & """" & _
" that satisfies the condition """ & sCondition & CStr(vCompare) & _
""" in column """ & iSearchCol & """")
End Function

Array_RemoveDuplicatesColsRows

Public Sub Array_RemoveDuplicatesColsRows( _
ByRef vArrayValues As Variant, _
ByVal iUniqueCol As Integer)

Const sPROCNAME As String = "Array_RemoveDuplicatesColsRows"

Dim vTempArray As Variant
Dim icolno As Integer
Dim lrowno As Long
Dim lrownext As Long

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

ReDim vTempArray(1 To UBound(vArrayValues, 1), 1 To UBound(vArrayValues, 2))

For icolno = 1 To UBound(vArrayValues, 1)
vTempArray(icolno, 1) = vArrayValues(icolno, 1)
Next icolno
lrownext = 2
For lrowno = 2 To UBound(vArrayValues, 2)
If UCase(vArrayValues(iUniqueCol, lrowno)) <> UCase(vArrayValues(iUniqueCol, lrowno - 1)) Then
For icolno = 1 To UBound(vArrayValues, 1)
vTempArray(icolno, lrownext) = vArrayValues(icolno, lrowno)
Next icolno
lrownext = lrownext + 1
End If
Next lrowno

ReDim Preserve vTempArray(1 To UBound(vArrayValues, 1), 1 To lrownext - 1)
vArrayValues = vTempArray

Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Array_RemoveDuplicatesSingle

Removes any duplicate entries from a single dimensional array. Maybe use collections to add all entries and then populate again afterwards. Maybe use a collection ?? The slightly smaller single dimensional array is returned.
Public Function Array_RemoveDuplicatesSingle() As Variant

On Error GoTo AnError

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveDuplicatesSingle", msMODULENAME, 1, _
"remove any duplicate rows from the multi dimensional array " & _
"""" & sArrayName & """")
End Function

Array_RemoveMatchMulti

Removes all entries from a multi dimensional array that match a particular entry, in a given column. The slightly smaller multi dimensional array is returned.
Public Function Array_RemoveMatchMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal iSearchCol As Integer, _
ByVal sMatchText As String) _
As Variant

Dim larraycount1 As Long
Dim larraycount2 As Long
Dim lLower As Long
Dim lUpper As Long
Dim lfiltercount As Long
Dim vArrayFiltered As Variant
On Error GoTo AnError

If lLower = -1 Then lLower = LBound(vArrayName, 2)
If lUpper = -1 Then lUpper = UBound(vArrayName, 2)
lfiltercount = 1
ReDim vArrayFiltered(lfiltercount, lUpper)
For larraycount1 = lLower To lUpper
If vArrayName(larraycount1, iSearchCol) = sMatchText Then
ReDim vArrayFiltered(lfiltercount + 1, lUpper)
For larraycount2 = LBound(vArrayName, 1) To UBound(vArrayName, 1)
vArrayFiltered(lfiltercount, larraycount2) = _
vArrayName(larraycount1, larraycount2)
Next larraycount2
lfiltercount = lfiltercount + 1
End If
Next larraycount1
Array_RemoveMatchMulti = vArrayFiltered

If gbDEBUG = False Then Exit Function
AnError:
Array_RemoveMatchMulti = vArrayName
Call Error_Handle("Array_RemoveMatchMulti", msMODULENAME, 1, _
"remove all the entries in the multi dimensional array """ & sArrayName & """" & _
" that match """ & sMatchText & """ in column """ & iSearchCol & """")
End Function

Array_RemoveMatchSingle

Removes all entries from a single dimensional array that match a particular entry. The slightly smaller single dimensional array is returned.
Public Function Array_RemoveMatchSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sMatchText As String) _
As Variant

On Error GoTo AnError


Array_RemoveMatchSingle = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveMatchSingle", msMODULENAME, 1, _
"remove all the entries in the single dimensional array """ & sArrayName & """" & _
"that match """ & sMatchText & """")
End Function

Array_RemovePreceedingDoubleChars

Removes ??? From all entries in a multi dimensional array What does this do ????.
Public Function Array_RemovePreceedingDoubleChars( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal sChar As String = " ") _
As Variant

Dim lrowcount As Long
Dim icolumncount As Long
Dim sBefore As String
Dim scontents As String
Dim sfinaltext As String
On Error GoTo AnError

For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
For lrowcount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
sfinaltext = ""
scontents = vArrayName(icolumncount, lrowcount, 0)
sBefore = scontents
Do While Len(scontents) > 0
If Left(scontents, 2) <> (sChar & sChar) Then
sfinaltext = sfinaltext & Left(scontents, 1)
End If
scontents = Right$(scontents, Len(scontents) - 1)
Loop

If (sBefore <> sfinaltext) Then
vArrayName(icolumncount, lrowcount, 0) = sfinaltext
vArrayName(icolumncount, lrowcount, 1) = "1"
Else
If vArrayName(icolumncount, lrowcount, 1) <> "1" Then _
vArrayName(icolumncount, lrowcount, 1) = "0"
End If
Next lrowcount
Next icolumncount
Array_RemovePreceedingDoubleChars = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Array_RemovePreceedingDoubleChars = vArrayName
Call Error_Handle("Array_RemovePreceedingDoubleChars", msMODULENAME, 1, _
"remove all the preceeding double characters from the multi dimensional array" & _
"""" & sArrayName & """")
End Function

Array_RemovePrefix

Public Function Array_RemovePrefix( _
ByVal vaArray As Variant, _
ByVal sCharFind As String) _
As Variant

Dim larrayno As Long
Dim ifindchar As Integer

On Error GoTo AnError

For larrayno = 0 To UBound(vaArray)
ifindchar = InStr(vaArray(larrayno), sCharFind)

vaArray(larrayno) = Right(vaArray(larrayno), Len(vaArray(larrayno)) - ifindchar)
Next larrayno

Array_RemovePrefix = vaArray
Exit Function

AnError:
' Call MsgBox("There has been an error sorting")
End Function

Array_RemoveSpacesMulti

Removes all the preceeding or trailing spaces from all the entries in a particular column in a multi dimensional array.
Public Function Array_RemoveSpacesMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant) _
As Variant

Dim lrowcount As Long
Dim icolumncount As Integer
Dim scontents As String

On Error GoTo AnError
For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
For lrowcount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
scontents = vArrayName(icolumncount, lrowcount, 0)
If Left$(scontents, 1) = " " Or _
Right$(scontents, 1) = " " Then
vArrayName(icolumncount, lrowcount, 0) = Trim$(scontents)
vArrayName(icolumncount, lrowcount, 1) = "1"
Else
If vArrayName(icolumncount, lrowcount, 1) <> "1" Then _
vArrayName(icolumncount, lrowcount, 1) = "0"
End If
Next lrowcount
Next icolumncount
Array_RemoveSpacesMulti = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveSpacesMulti", msMODULENAME, 1, _
"remove all the leading and trailing spaces from all the entires" & _
" in the multi dimensional array """ & sArrayName & """")
End Function

Array_RemoveSpacesSingle

Removes all the preceeding or trailing spaces from all the entries in a single dimensional array.
Public Function Array_RemoveSpacesSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant) _
As Variant

On Error GoTo AnError

'TRIM every element

Array_RemoveSpacesSingle = vArrayName

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_RemoveSpacesSingle", msMODULENAME, 1, _
"remove all the leading and trailing spaces from all the entries" & _
" in the multi dimensional array """ & sArrayName & """")
End Function

Array_ReturnColMulti

Returns the first column that matches the particular entry in a given row. Normally used to search the first header row to deduce the correct array dimension.
Public Function Array_ReturnColMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sMatchText As String, _
Optional ByVal sEqualOrNot As String = "EQUAL", _
Optional ByVal iStartCol As Integer = 1, _
Optional ByVal lSearchRow As Long = 1) As Integer

Const sPROCNAME As String = "Array_ReturnColMulti"
Dim icolumncount As Integer
On Error GoTo ErrorHandler

If (sEqualOrNot = "EQUAL") Then
For icolumncount = iStartCol To UBound(vArrayName, 2)
If (vArrayName(lSearchRow, icolumncount) = sMatchText) Then
Array_ReturnCol = icolumncount
Exit Function
End If
Next icolumncount
End If
If sEqualOrNot = "NOTEQUAL" Then
For icolumncount = iStartCol To UBound(vArrayName, 2)
If (vArrayName(lSearchRow, icolumncount) <> sMatchText) Then
Array_ReturnCol = icolumncount
Exit Function
End If
Next icolumncount
End If
Array_ReturnColMulti = UBound(vArrayName, 2)

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the first column that matches """ & sMatchText & """" & _
" in row """ & lSearchRow & """ in the array """ & sArrayName & """")
End Function

Array_ReverseMulti

Reverses the order of a multi dimensional array sorting on a given column. Used when an array is sorted ASC or DESC.
Public Sub Array_ReverseMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1)

Const sPROCNAME As String = "Array_ReverseMulti"
Dim larraycount As Long
Dim stemp As String
Dim icolumncount As Integer
On Error GoTo ErrorHandler

If Array_Check(vArrayName) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(vArrayName, 1)
If lUpper = -1 Then
lUpper = 0
For larraycount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
If (IsEmpty(vArrayName(larraycount, 1)) = False) Then
lUpper = lUpper + 1
End If
Next larraycount
End If

Do While lLower < lUpper
For larraycount = LBound(vArrayName, 2) To _
UBound(vArrayName, 2)
If (IsEmpty(vArrayName(lLower, larraycount)) = True) Then
vArrayName(lLower, larraycount) = ""
End If
stemp = CStr(vArrayName(lLower, icolumncount))
vArrayName(lLower, larraycount) = CStr(vArrayName(lUpper, larraycount))
vArrayName(lUpper, larraycount) = stemp
Next larraycount
lLower = lLower + 1
lUpper = lUpper - 1
Loop

If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"reverse the order of the multi dimensional array " & """" & sArrayName & """")
End Sub

Array_ReverseSingle

Reverses the order of a single dimensional array. Used when an array is sorted ASC or DESC.
Public Function Array_ReverseSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant) As Variant

On Error GoTo ErrorHandler

Array_ReverseSingle = vArrayName

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Array_ReverseSingle", msMODULENAME, 1, _
"reverse the order of entries" & _
" in the single dimensional array """ & sArrayName & """")
End Function

Array_SortMulti1

Public Function Array_SortMulti1(ByVal sArrayName1Sort As String, _
ByRef vArrayName1Sort As Variant, _
ByVal iSortCol As Integer, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal bErrorInform As Boolean = True) As Variant
Const sPROCNAME As String = "Array_SortMulti1"
Dim lmiddle As Long
Dim lrowupper As Long
Dim lrowlower As Long
Dim vmiddlevalue As Variant
Dim stemp As String
Dim icolumncount As Integer
On Error GoTo ErrorHandler
If IsEmpty(sArrayName1Sort) = True Then Exit Function
If lLower = -1 Then lLower = LBound(vArrayName1Sort, 1)
If lUpper = -1 Then
lUpper = 0
For lrowlower = LBound(vArrayName1Sort, 1) To UBound(vArrayName1Sort, 1)
If (IsEmpty(vArrayName1Sort(lrowlower, 1)) = False) Then lUpper = lUpper + 1
Next lrowlower
End If

If lLower < lUpper Then
lmiddle = (lLower + lUpper) / 2
vmiddlevalue = CStr(vArrayName1Sort(lmiddle, iSortCol))
lrowlower = lLower
lrowupper = lUpper
Do While lrowlower < lrowupper
Do While (CStr(vArrayName1Sort(lrowlower, iSortCol)) < vmiddlevalue)
lrowlower = lrowlower + 1
Loop
Do While (vmiddlevalue < CStr(vArrayName1Sort(lrowupper, iSortCol)))
lrowupper = lrowupper - 1
Loop
If (lrowlower <= lrowupper) Then
For icolumncount = LBound(vArrayName1Sort, 2) To _
UBound(vArrayName1Sort, 2)

If IsEmpty(vArrayName1Sort(lrowlower, icolumncount)) = True Then
vArrayName1Sort(lrowlower, icolumncount) = ""
End If

stemp = CStr(vArrayName1Sort(lrowlower, icolumncount))

vArrayName1Sort(lrowlower, icolumncount) = _
CStr(vArrayName1Sort(lrowupper, icolumncount))

vArrayName1Sort(lrowupper, icolumncount) = stemp
Next icolumncount
lrowlower = lrowlower + 1
lrowupper = lrowupper - 1
End If
Loop
If (lrowupper <= lmiddle) Then
Call Array_SortMulti1(sArrayName1Sort, vArrayName1Sort, _
iSortCol, lLower, lrowupper, bErrorInform)
Call Array_SortMulti1(sArrayName1Sort, vArrayName1Sort, _
iSortCol, lrowlower, lUpper, bErrorInform)
Else
Call Array_SortMulti1(sArrayName1Sort, vArrayName1Sort, _
iSortCol, lrowlower, lUpper, bErrorInform)
Call Array_SortMulti1(sArrayName1Sort, vArrayName1Sort, _
iSortCol, lLower, lrowupper, bErrorInform)
End If
End If
Exit Function
ErrorHandler:
If bErrorInform = True Then
Call Error_Handle(msMODULENAME, sPROCNAME, 1, _
"sort the multi dimensional array " & _
"""" & sArrayName1Sort & """ into ascending order")
End If
End Function

Array_SortMulti2

Sorts two multi dimensional array into ascending order. The array variable is replaced with the new sorted array TEST !!!! - Are you ever going to need to do this.
Public Sub Array_SortMulti2(ByVal sArrayName1Sort As String, _
ByVal vArrayName1Sort As Variant, _
ByVal sArrayName2 As String, _
ByVal vArrayName2 As Variant, _
ByVal iSortCol As Integer, _
Optional ByVal lupper As Long = -1, _
Optional ByVal llower As Long = -1, _
Optional ByVal bErrorInform As Boolean = True)
Dim vmiddlevalue As Variant
Dim lmiddle As Long
Dim lrowupper As Long
Dim lrowlower As Long
Dim stemp As String
Dim icolumncount As Integer
On Error GoTo AnError
If IsEmpty(sArrayName1Sort) = True Then Exit Sub
If IsEmpty(vArrayName2) = True Then Exit Sub
If llower = -1 Then llower = LBound(vArrayName1Sort, 1)
If lupper = -1 Then
lupper = 0
For lrowlower = LBound(vArrayName1Sort, 1) To UBound(vArrayName1Sort, 1)
If (IsEmpty(vArrayName1Sort(lrowlower, 1)) = False) Then lupper = lupper + 1
Next lrowlower
End If

If llower < lupper Then
lmiddle = (llower + lupper) / 2
vmiddlevalue = CStr(vArrayName1Sort(lmiddle, iSortCol))
lrowlower = llower
lrowupper = lupper
Do While lrowlower < lrowupper
Do While (CStr(vArrayName1Sort(lrowlower, iSortCol)) < vmiddlevalue)
lrowlower = lrowlower + 1
Loop
Do While (vmiddlevalue < CStr(vArrayName1Sort(lrowupper, iSortCol)))
lrowupper = lrowupper - 1
Loop
If (lrowlower <= lrowupper) Then
For icolumncount = LBound(vArrayName1Sort, 2) To _
UBound(vArrayName1Sort, 2)

If IsEmpty(vArrayName1Sort(lrowlower, icolumncount)) = True Then _
vArrayName1Sort(lrowlower, icolumncount) = ""

If IsEmpty(vArrayName(lrowlower, icolumncount)) = True Then _
vArrayName(lrowlower, icolumncount) = ""

stemp1 = CStr(vArrayName1Sort(lrowlower, icolumncount))
stemp2 = CStr(vArrayName(lrowlower, icolumncount))

vArrayName1Sort(lrowlower, icolumncount) = _
CStr(vArrayName1Sort(lrowupper, icolumncount))
vArrayName(lrowlower, icolumncount) = _
CStr(vArrayName(lrowupper, icolumncount))

vArrayName1Sort(lrowupper, icolumncount) = stemp
vArrayName(lrowupper, icolumncount) = stemp
Next icolumncount
lrowlower = lrowlower + 1
lrowupper = lrowupper - 1
End If
Loop
If (lrowupper <= lmiddle) Then
Call Array_SortMulti2(sArrayName1Sort, vArrayName1Sort, sArrayName, vArrayName, _
iSortCol, llower, lrowupper, bErrorInform)
Call Array_SortMulti2(sArrayName1Sort, vArrayName1Sort, sArrayName, vArrayName, _
iSortCol, lrowlower, lupper, bErrorInform)
Else
Call Array_SortMulti2(sArrayName1Sort, vArrayName1Sort, sArrayName, vArrayName, _
iSortCol, lrowlower, lupper, bErrorInform)
Call Array_SortMulti2(sArrayName1Sort, vArrayName1Sort, sArrayName, vArrayName, _
iSortCol, llower, lrowupper, bErrorInform)
End If
End If
If gbDEBUG = False Then Exit Sub
AnError:
If bErrorInform = True Then
Call Error_Handle("Array_SortMulti2", msMODULENAME, 1, _
"sort the two multi dimensional arrays " & _
"""" & sArrayName1Sort & """ and """ & sArrayName2 & """ into ascending order")
End If
End Sub

Array_SortQuickMulti1ColRowNumber

Public Sub Array_SortQuickMulti1ColRowNumber(ByVal sArrayName As String, _
ByRef varrayname As Variant, _
ByVal iSortCol As Integer, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1)
Dim vmiddlevalue As Variant
Dim lmiddle As Long
Dim lrowupper As Long
Dim lrowlower As Long
Dim stemp As String
Dim icolumncount As Integer
On Error GoTo AnError
If IsEmpty(varrayname) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(varrayname, 2)
If lUpper = -1 Then lUpper = UBound(varrayname, 2)

If lLower < lUpper Then
lmiddle = lLower

ReDim vmiddlevalue(LBound(varrayname, 1) To UBound(varrayname, 1))
For icolumncount = LBound(varrayname, 1) To UBound(varrayname, 1)
vmiddlevalue(icolumncount) = varrayname(icolumncount, lmiddle)
Next icolumncount

lrowlower = lLower
lrowupper = lUpper

Do While lrowlower < lrowupper
Do While CDbl(varrayname(iSortCol, lrowupper)) >= CDbl(vmiddlevalue(iSortCol)) And _
(lrowlower < lrowupper)
lrowupper = lrowupper - 1
Loop
If (lrowlower <> lrowupper) Then
For icolumncount = LBound(varrayname, 1) To UBound(varrayname, 1)
If IsEmpty(varrayname(icolumncount, lrowlower)) = True Then
varrayname(icolumncount, lrowlower) = ""
End If
stemp = varrayname(icolumncount, lrowlower)
varrayname(icolumncount, lrowlower) = varrayname(icolumncount, lrowupper)
varrayname(icolumncount, lrowupper) = stemp
Next icolumncount

lrowlower = lrowlower + 1
End If

Do While CDbl((varrayname(iSortCol, lrowlower)) <= CDbl(vmiddlevalue(iSortCol))) And _
(lrowlower < lrowupper)
lrowlower = lrowlower + 1
Loop
If (lrowlower <> lrowupper) Then
For icolumncount = LBound(varrayname, 1) To UBound(varrayname, 1)
If IsEmpty(varrayname(icolumncount, lrowlower)) = True Then
varrayname(icolumncount, lrowlower) = ""
End If
stemp = varrayname(icolumncount, lrowupper)
varrayname(icolumncount, lrowupper) = varrayname(icolumncount, lrowlower)
varrayname(icolumncount, lrowlower) = stemp
Next icolumncount

lrowupper = lrowupper - 1
End If
Loop

For icolumncount = LBound(varrayname, 1) To UBound(varrayname, 1)
varrayname(icolumncount, lrowlower) = vmiddlevalue(icolumncount)
Next icolumncount

lmiddle = lrowlower
lrowlower = lLower
lrowupper = lUpper

If (lrowlower < lmiddle) Then
Call Array_SortQuickMulti1ColRowNumber(sArrayName, varrayname, iSortCol, lrowlower, lmiddle - 1)
End If
If (lrowupper > lmiddle) Then
Call Array_SortQuickMulti1ColRowNumber(sArrayName, varrayname, iSortCol, lmiddle + 1, lrowupper)
End If
End If
If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
Call Error_Handle("Array_SortQuickMulti1ColRowNumber", msMODULENAME, _
"sort the 1 'Numerical' multi dimensional array " & _
"'" & sArrayName & "' into ascending order.")
End Sub

Array_SortQuickMulti1ColRowVariant

Public Sub Array_SortQuickMulti1ColRowVariant(ByVal sArrayName As String, _
ByRef vArrayName As Variant, _
ByVal iSortCol As Integer, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1)

Const sPROCNAME As String = "Array_SortQuickMulti1ColRowVariant"

Dim vmiddlevalue() As Variant
Dim lmiddle As Long
Dim lrowupper As Long
Dim lrowlower As Long
Dim stemp As String
Dim icolumncount As Integer

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

If IsEmpty(vArrayName) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(vArrayName, 2)
If lUpper = -1 Then lUpper = UBound(vArrayName, 2)

If lLower < lUpper Then
lmiddle = lLower

ReDim vmiddlevalue(LBound(vArrayName, 1) To UBound(vArrayName, 1))
For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
vmiddlevalue(icolumncount) = vArrayName(icolumncount, lmiddle)
Next icolumncount

lrowlower = lLower
lrowupper = lUpper

Do While lrowlower < lrowupper
Do While (vArrayName(iSortCol, lrowupper) >= vmiddlevalue(iSortCol)) And _
(lrowlower < lrowupper)
lrowupper = lrowupper - 1
Loop
If (lrowlower <> lrowupper) Then
For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
If IsEmpty(vArrayName(icolumncount, lrowlower)) = True Then
vArrayName(icolumncount, lrowlower) = ""
End If
stemp = vArrayName(icolumncount, lrowlower)
vArrayName(icolumncount, lrowlower) = vArrayName(icolumncount, lrowupper)
vArrayName(icolumncount, lrowupper) = stemp
Next icolumncount

lrowlower = lrowlower + 1
End If

Do While (vArrayName(iSortCol, lrowlower) <= vmiddlevalue(iSortCol)) And _
(lrowlower < lrowupper)
lrowlower = lrowlower + 1
Loop
If (lrowlower <> lrowupper) Then
For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
If IsEmpty(vArrayName(icolumncount, lrowlower)) = True Then
vArrayName(icolumncount, lrowlower) = ""
End If
stemp = vArrayName(icolumncount, lrowupper)
vArrayName(icolumncount, lrowupper) = vArrayName(icolumncount, lrowlower)
vArrayName(icolumncount, lrowlower) = stemp
Next icolumncount

lrowupper = lrowupper - 1
End If
Loop

For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
vArrayName(icolumncount, lrowlower) = vmiddlevalue(icolumncount)
Next icolumncount

lmiddle = lrowlower
lrowlower = lLower
lrowupper = lUpper

If (lrowlower < lmiddle) Then
Call Array_SortQuickMulti1ColRowVariant(sArrayName, vArrayName, iSortCol, lrowlower, lmiddle - 1)
End If
If (lrowupper > lmiddle) Then
Call Array_SortQuickMulti1ColRowVariant(sArrayName, vArrayName, iSortCol, lmiddle + 1, lrowupper)
End If
End If

Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"sort the 1 'Variant' multi dimensional array " & _
"'" & sArrayName & "' into ascending order.")
End Sub

Array_SortQuickSingle1Variant

Public Sub Array_SortQuickSingle1Variant(ByVal sArrayName As String, _
ByRef varrayname As Variant, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1)

Const sPROCNAME As String = "Array_SortQuickSingle1Variant"

Dim vmiddlevalue As Variant
Dim lmiddle As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim stemp As String

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

If IsEmpty(varrayname) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(varrayname, 1)
If lUpper = -1 Then lUpper = UBound(varrayname, 1)

If lLower < lUpper Then
lmiddle = lLower
vmiddlevalue = varrayname(lmiddle)
lrowlower = lLower
lrowupper = lUpper

Do While lrowlower < lrowupper
Do While (varrayname(lrowupper) >= vmiddlevalue) And (lrowlower < lrowupper)
lrowupper = lrowupper - 1
Loop
If (lrowlower <> lrowupper) Then
stemp = varrayname(lrowlower)
varrayname(lrowlower) = varrayname(lrowupper)
varrayname(lrowupper) = stemp
lrowlower = lrowlower + 1
End If

Do While (varrayname(lrowlower) <= vmiddlevalue) And (lrowlower < lrowupper)
lrowlower = lrowlower + 1
Loop
If (lrowlower <> lrowupper) Then
stemp = varrayname(lrowupper)
varrayname(lrowupper) = varrayname(lrowlower)
varrayname(lrowlower) = stemp
lrowupper = lrowupper - 1
End If
Loop

varrayname(lrowlower) = vmiddlevalue
lmiddle = lrowlower
lrowlower = lLower
lrowupper = lUpper

If (lrowlower < lmiddle) Then
Call Array_SortQuickSingle1Variant(sArrayName, varrayname, lrowlower, lmiddle - 1)
End If
If (lrowupper > lmiddle) Then
Call Array_SortQuickSingle1Variant(sArrayName, varrayname, lmiddle + 1, lrowupper)
End If
End If
If gbDEBUG_ERRMSG = False Then Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"sort the 1 'Variant' single dimensional array " & _
"'" & sArrayName & "' into ascending order.")
End Sub

Array_ToArrayMulti

Copies all the contents from a given column in a multi dimensional array to a column in another multi dimensional array.
Public Function Array_ToArrayMulti(ByVal sArrayNameCopyFrom As String, _
ByVal vArrayNameCopyFrom As Variant, _
ByVal iCopyFromCol As Integer, _
ByVal sArrayNameCopyTo As String, _
ByVal vArrayNameCopyTo As Variant, _
ByVal iCopyToCol As Integer) As Variant
Dim larraycount As Long
On Error GoTo AnError
If (UBound(vArrayNameCopyFrom, 1) <> UBound(vArrayNameCopyTo, 1)) And _
(iCopyFromCol <= UBound(vArrayNameCopyFrom, 2)) And _
(iCopyToCol <= UBound(vArrayNameCopyTo, 2)) Then
' Call Frm_Inform(msMODULENAME,
Call MsgBox( _
"transfer the elements from array """ & sArrayNameCopyFrom & """" & _
" to the array """ & sArrayNameCopyTo & """" & vbCrLf & _
"since the dimensions are different")
Else
For larraycount = LBound(vArrayNameCopyFrom, 2) To UBound(vArrayNameCopyFrom, 2)
vArrayNameCopyTo(iCopyToCol, larraycount) = _
vArrayNameCopyFrom(iCopyFromCol, larraycount)
Next larraycount
End If
Array_ToArrayMulti = vArrayNameCopyTo
If gbDEBUG = False Then Exit Function
AnError:
Array_ToArrayMulti = vArrayNameCopyFrom
Call Error_Handle("Array_ToArrayMulti", msMODULENAME, 1, _
"transfer the elements from column " & iCopyFromCol & _
" in multi dimensional array """ & sArrayNameCopyFrom & """" & _
" to the column " & iCopyToCol & _
" in the multi dimensional array """ & sArrayNameCopyTo & """")
End Function

Array_ToArrayUnique

Public Function Array_ToArrayUnique(ByVal sArrayName As String, _
ByVal vArrayName As Variant) As Variant
Dim varraytemp As Variant
Dim ifindunder As Integer
Dim sprevious As String
Dim scurrent As String
Dim colunique As New Collection
Dim larraycount As Long
On Error GoTo AnError
ifindunder = InStr(vArrayName(1, 1), "_")
If ifindunder > 0 Then sprevious = Left(vArrayName(1, 1), ifindunder - 1)
If ifindunder = 0 Then sprevious = vArrayName(1, 1)
colunique.Add sprevious
For larraycount = LBound(vArrayName, 2) + 1 To UBound(vArrayName, 2)
ifindunder = InStr(vArrayName(1, larraycount), "_")
If ifindunder > 0 Then scurrent = Left(vArrayName(1, larraycount), ifindunder - 1)
If ifindunder = 0 Then scurrent = vArrayName(1, larraycount)
If scurrent <> sprevious Then
colunique.Add scurrent
End If
sprevious = scurrent
Next larraycount
ReDim varraytemp(colunique.Count)
For larraycount = 1 To colunique.Count
varraytemp(larraycount) = colunique.Item(larraycount)
Next larraycount
Array_ToArrayUnique = varraytemp
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_ToArrayUnique", msMODULENAME, 1, _
"to return an array of unique elements")
End Function

Array_ToListComboBoxMulti

Transfers the contents of a multi dimensional array to a listbox or combobox. This assigns the array to the listbox in one go TEST error message - What is the difference ??.
Public Sub Array_ToListComboBoxMulti(ByVal lstBoxName As Control, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal bMultiArray As Boolean = False, _
Optional ByVal sColumnWidths As String = "", _
Optional ByVal bClearList As Boolean = True)
Dim lrowcount As Long
Dim icolumncount As Integer
Dim serrortext As String
On Error GoTo AnError
If bClearList = True Then lstBoxName.Clear
If bMultiArray = True Then lstBoxName.ColumnCount = UBound(vArrayName, 1)
If Len(sColumnWidths) > 0 Then lstBoxName.ColumnWidths = sColumnWidths
For lrowcount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
lstBoxName.AddItem vArrayName(1, lrowcount)
For icolumncount = LBound(vArrayName, 1) To UBound(vArrayName, 1) - 1
lstBoxName.List(lrowcount - 1, icolumncount) = vArrayName(icolumncount + 1, lrowcount)
Next icolumncount
Next lrowcount
If gbDEBUG = False Then Exit Sub
AnError:
If bMultiArray = True Then serrortext = "Multi"
If bMultiArray = False Then serrortext = "Single"
Call Error_Handle("Array_ToListComboBoxMulti", msMODULENAME, 1, _
"transfer the contents of the multi dimensional array """ & sArrayName & """" & _
" to the listbox """ & lstBoxName.Name & """ in one go")
End Sub

Array_ToListComboSingle2

Public Sub Array_ToListComboBoxSingle2(ByVal lstBoxName As Control, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal iDimension As Integer = 1, _
Optional ByVal bMultiArray As Boolean = False, _
Optional ByVal bClearList As Boolean = True)
Dim lrowcount As Long
On Error GoTo AnError
If bClearList = True Then lstBoxName.Clear
If Array_Check(vArrayName, bMultiArray) = False Then Exit Sub
If bMultiArray = True Then
For lrowcount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
If Len(CStr(vArrayName(iDimension, lrowcount))) > 0 Then
lstBoxName.AddItem CStr(vArrayName(iDimension, lrowcount))
End If
Next lrowcount
End If
If bMultiArray = False Then
For lrowcount = LBound(vArrayName) To UBound(vArrayName)
If Len(CStr(vArrayName(lrowcount))) > 0 Then
lstBoxName.AddItem CStr(vArrayName(lrowcount))
End If
Next lrowcount
End If

Exit Sub
AnError:
Call Error_Handle("Array_ToListComboSingle2", msMODULENAME, 1, _
"transfer the contents of the multi dimensional array """ & sArrayName & """" & _
" to the listbox """ & lstBoxName.Name & """ an element at a time")
End Sub

Array_ToStringColumnUnique

Public Function Array_ToStringColumnUnique( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal iUniqueColumn As Integer, _
Optional ByVal sSeperatorChar As String = ";") As String

Const sPROCNAME As String = "Array_ToArrayColumnUniqueItems"
Dim sconcat As String
Dim sitem As String
Dim larraycount As Long

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

sconcat = sSeperatorChar
For larraycount = LBound(vArrayName, 1) To UBound(vArrayName, 1)
sitem = vArrayName(larraycount, iUniqueColumn)
If (Len(sitem) > 0) Then
If InStr(1, sconcat, sSeperatorChar & sitem & sSeperatorChar) = 0 Then
sconcat = sconcat & vArrayName(larraycount, iUniqueColumn) & sSeperatorChar
End If
End If
Next larraycount

If (Len(sconcat) > 0) Then
sconcat = Right(sconcat, Len(sconcat) - 1)
sconcat = Left(sconcat, Len(sconcat) - 1)
End If

Array_ToStringColumnUnique = sconcat

Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Array_ToStringMulti

Transfers the contents of a multi dimensional array to a string concatenation with a seperator character.
Public Function Array_ToStringMulti(ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal iColumnNo As Integer = 1, _
Optional ByVal sSeperatorChar As String = ";") As String

Const sPROCNAME As String = "Array_ToStringMulti"

Dim sconcat As String
Dim larraycount As Long

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

For larraycount = LBound(vArrayName, 2) To UBound(vArrayName, 2)
sconcat = sconcat & vArrayName(iColumnNo, larraycount) & sSeperatorChar
Next larraycount

If (Len(sconcat) > 0) Then Array_ToStringMulti = Left(sconcat, Len(sconcat) - 1)
If (Len(sconcat) = 0) Then Array_ToStringMulti = ""
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"transfer the contents of the multi dimensional array " & _
"""" & sArrayName & """, column " & _
iColumnNo & " to a string concatenation seperated by the char " & _
"""" & sSeperatorChar & """")
End Function

Array_ToStringSingle

Transfers the contents of a single dimensional array to a string concatenation with a seperator character.
Public Sub Array_ToStringSingle(ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal sSeperatorChar As String = ";")
Dim sconcat As String
Dim larrayno As Long
On Error GoTo AnError

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Array_ToStringSingle", msMODULENAME, 1, _
"transfer the contents of the array """ & sArrayName & """" & _
" to a string concatenation seperated by the char " & _
"""" & sSeperatorChar & """")
End Sub

Array_ToTableAdd

Transfers the contents of an array to an existing table.
Public Sub Array_ToTableAdd(ByVal vArrayName As Variant, _
Optional ByVal iColStart As Integer = 1, _
Optional ByVal iRowStart As Integer = 1)
Dim itotalcolumns As Integer
Dim icolumnnumber As Integer
Dim itotalrows As Integer
Dim irownumber As Integer
On Error GoTo AnError
Application.StatusBar = "Adding an array over the table ..."
itotalcolumns = Selection.Tables(1).Columns.count
itotalrows = Selection.Tables(1).Rows.count
For icolumnnumber = iColStart To itotalcolumns
For irownumber = irowstart To itotalrows
If vArrayName(icolumnnumber - 1, irownumber - 1, 1) = "1" Then _
Selection.Tables(1).cell(irownumber, icolumnnumber).Range.Text = _
vArrayName(icolumnnumber - 1, irownumber - 1, 0)
Next irownumber
Next icolumnnumber
Application.StatusBar = False
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Array_ToTableAdd", msMODULENAME, 1, _
"transfer the contents of the array """ & sArrayName & """" & _
"into the active table, starting (" & iColStart & "," & iRowStart & ")")
End Sub

Array_ToTableMulti

Transfers the contents of an array and places them into a new table.
Public Sub Array_ToTableMulti(ByVal sArrayName as String, _
ByVal vArrayName as Variant)
On Error GoTo AnError


If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Array_ToTableMulti", msMODULENAME, 1, _
"transfer the contents of the array """ & sArrayName & """" & _
"into a new table")
End Sub

Array_ToTableSingle

Transfers the contents of an array and places them into a new table.
Public Sub Array_ToTableSingle(ByVal sArrayName as String, _
ByVal vArrayName as Variant)
On Error GoTo AnError


If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Array_ToTableSingle", msMODULENAME, 1, _
"transfer the contents of the array """ & sArrayName & """" & _
"into a new table")
End Sub

Array_ToTextFileMulti

Transfers the contents of a multi dimensional array to a text file with a seperator character.
Public Function Array_ToTextFileMulti(ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sFolderPath As String, _
ByVal iNoOfCols As Integer, _
ByVal sTextFile As String, _
Optional ByVal sExtension As String = ".txt", _
Optional ByVal bBlankLine As Boolean = True, _
Optional ByVal bDeleteExisting As Boolean = True) As Integer
Dim iFileNo As Integer
Dim itotalrecords As Integer
Dim iarraycount As Integer
Dim icolcount As Integer
On Error GoTo AnError
If (bDeleteExisting = True) And _
(File_Exists(sFolderPath & sTextFile & sExtension) = True) Then _
Call File_Delete(sFolderPath & sTextFile & sExtension)
iFileNo = FreeFile 'get the next free file number
Open sTextFile For Output As iFileNo

If Array_IsNothing(vArrayName) = True Then
itotalrecords = 0
Else: itotalrecords = UBound(vClient_Array, 2)
End If

For iarraycount = 2 To itotalrecords
For icolcount = 1 To iARRAYCLIENT_TOTAL
Print #iFileNo, vArrayName(icolcount, iarraycount)
Next icolcount
' print blank line after record
If (bBlankLine = True) And (itotalrecords > iarraycount) Then Print #iFileNo,
Next iarraycount
Close iFileNo
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Array_ToStringMulti", msMODULENAME, 1, _
"update your Address Book with the latest changes" & _
vbCrLf & sERRORMESSAGE, vbCritical, "AddressBook_Write")
If bDEBUG = False Then End
End Function

Array_ToTextFileSingle

Transfers the contents of a single dimensional array to a text file.
Public Sub Array_ToTextFile(ByVal vaArray As Variant, _
ByVal sFileName As String, _
Optional ByVal bDeleteExistingFile As Boolean = False)

Dim scrFile As Scripting.FileSystemObject
Dim scrText As Scripting.TextStream
Dim larrayno As Long

On Error GoTo AnError

Set scrFile = New Scripting.FileSystemObject

If bDeleteExistingFile = True Then
If scrFile.FileExists(sFileName) Then
scrFile.DeleteFile (sFileName)
End If
End If

Set scrText = scrFile.OpenTextFile(sFileName, ForWriting, True)

For larrayno = 0 To UBound(vaArray)
scrText.WriteLine vaArray(larrayno)
Next larrayno

scrText.Close

Set scrFile = Nothing
Set scrText = Nothing
If gbDEBUG = False Then Exit Sub

AnError:
Call Error_Handle("Array_ToTextFile", msMODULENAME, 1, _
"")
End Sub

Array_Transpose

Transposes all the rows and columns of a multi dimensional array. You could use the following although it does not seem very reliable ' vArrayNameTransposed = Application.Transpose(vArrayName) ???.
Public Sub Array_Transpose( _
ByVal sArrayName As String, _
ByRef vArrayName As Variant, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1, _
Optional ByVal bInformUser As Boolean = False)

Const sPROCNAME As String = "Array_Transpose"
Dim larrayno1 As Long
Dim larrayno2 As Long
Dim vArrayNameTransposed As Variant

On Error GoTo ErrorHandler
If Not IsEmpty(vArrayName) Then
If lLower = -1 Then lLower = LBound(vArrayName, 2)
If lUpper = -1 Then lUpper = UBound(vArrayName, 2)
ReDim vArrayNameTransposed(lUpper, UBound(vArrayName, 1))
For larrayno1 = 0 To UBound(vArrayName, 1)
For larrayno2 = lLower To lUpper
vArrayNameTransposed(larrayno2, larrayno1) = _
vArrayName(larrayno1, larrayno2)
Next larrayno2
Next larrayno1
vArrayName = vArrayNameTransposed
Else
If bInformUser = True Then
Call MsgBox("This array is empty !!")
End If
End If

If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"transpose the array """ & sArrayName & """" & vbCrLf & _
"(ie interchange the rows and columns)")
End Sub

Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function

Array_TwoItemsExistInMulti

Public Function Array_TwoItemsExistInMulti( _
ByVal vaArray As Variant, _
ByVal sColumn1Value As String, _
ByVal sColumn2Value As String) As Boolean

Dim lcount As Long
ArrayTwoColumnsExist = False

For lcount = 0 To UBound(vaArray, 1)
If (vaArray(lcount, 0) = sColumn1Value) And _
(vaArray(lcount, 1) = sColumn2Value) Then
ArrayTwoColumnsExist = True
Exit Function
End If
Next lcount
End Function

Array_ValueLargestMulti

Returns the largest value from a given column in a multi dimensional array.
Public Sub Array_ValueLargestMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal iColumnNo As Integer)

On Error GoTo ErrorHandler


If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle("Array_ValueLargestMulti", msMODULENAME, 1, _
"return the largest number in the " & _
"multi dimensional array """ & sArrayName & """, column " & iColumnNo)
End Sub

Array_ValueLargestSingle

Returns the largest value in a single dimensional array.
Public Function Array_ValueLargestSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant) As Double

Dim larraycount As Long
Dim dlarge As Double
On Error GoTo ErrorHandler

larraycount = LBound(vArrayName)
Do Until (vArrayName(larrayno) <> 0)
larraycount = larraycount + 1
Loop
dlarge = vArrayName(larrayno)
For larraycount = larraycount + 1 To UBound(vArrayName)
If (vArrayName(larraycount) <> 0) And _
(vArrayName(larraycount) > dlarge) Then dlarge = vArrayName(larraycount)
Next larraycount
Array_LargestValue = dlarge

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Array_ValueLargestSingle", msMODULENAME, 1, _
"return the largest number in the " & _
"single dimensional array """ & sArrayName & """")
End Function

Array_ValueSmallestMulti

Returns the smallest value from a given column in a multi dimensional array.
Public Function Array_ValueLargestSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant) As Double

Dim larrayno As Long
Dim dlarge As Double
On Error GoTo ErrorHandler

larrayno = LBound(vArrayName)
Do Until (vArrayName(larrayno) <> 0)
larrayno = larrayno + 1
Loop
dlarge = vArrayName(larrayno)
For larrayno = larrayno + 1 To UBound(vArrayName)
If (vArrayName(larrayno) <> 0) And _
(vArrayName(larrayno) > dlarge) Then dlarge = vArrayName(larrayno)
Next
Array_LargestValue = dlarge

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Array_ValueLargestSingle", msMODULENAME, 1, _
"return the largest number in the " & _
"single dimensional array """ & sArrayName & """")
End Function

Array_ValueSmallestSingle

Returns the smallest value in a single dimensional array.
Public Function Array_ValueSmallestSingle( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal lupper As Long = -1, _
Optional ByVal llower As Long = -1) As Double

Dim larrayno As Long
Dim dsmall As Double
On Error GoTo ErrorHandler

larrayno = LBound(vArrayName)
Do Until (vArrayName(larrayno) <> 0)
larrayno = larrayno + 1
Loop
dsmall = vArrayName(larrayno)
For larrayno = larrayno + 1 To UBound(vArrayName)
If (vArrayName(larrayno) <> 0) And _
(vArrayName(larrayno) < dsmall) Then dsmall = vArrayName(larrayno)
Next
Array_ValueSmallestSingle = dsmall

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Array_ValueSmallestSingle", msMODULENAME, 1, _
"return the smallest number in the single dimensional array " & _
"""" & sArrayName & """")
End Function

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top