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_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_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

Remove_AfterCharMulti

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

Remove_AfterCharSingle

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

Remove_CriteriaMulti

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

Remove_DuplicatesColsRows

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

Remove_DuplicatesSingle

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

Remove_MatchMulti

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

Remove_MatchSingle

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

Remove_PreceedingDoubleChars

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

Remove_Prefix

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

Remove_SpacesMulti

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

Remove_SpacesSingle

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

Sort_Multi1

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

Sort_Multi2

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

Sort_QuickMulti1ColRowNumber

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

Sort_QuickMulti1ColRowVariant

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

Sort_QuickSingle1Variant

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

To_ArrayMulti

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

To_ArrayUnique

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

To_ListComboBoxMulti

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

To_ListComboSingle2

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

To_StringColumnUnique

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

To_StringMulti

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

To_StringSingle

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

To_TableAdd

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

To_TableMulti

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

To_TableSingle

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

To_TextFileMulti

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

To_TextFileSingle

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

---

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