modUtilsNew.bas

Option Explicit

Enum RowCol
    FindRow = 1
    FindColumn = 2
End Enum
Enum PartialWholeMatch
    WholeMatch = 1
    PartialMatch = 2
End Enum
Enum AscendingDescending
    Ascending = 1
    Descending = 2
End Enum

' required libraries
'
' Microsoft Scripting Runtime
' Microsoft ActiveX Data Objects


' Workbook Functions
' 1.  wbk_ListNamedRanges
' 2.  wbk_ListNamedRangesAndAddresses
'
' Pivot Functions
' 1.  pvt_ListPivotTableDetails


' Range Functions


' Application Functions




' TBA
' Kill file


' WORKBOOK FUNCTIONS
Function wbk_ListNamedRanges(wbk As Workbook, Optional strPartialName As String) As Variant

Dim n As Name
Dim i As Integer
Dim varResult As Variant

ReDim varResult(0 To 0)

For Each n In wbk.Names

    If strPartialName <> "" Then
        If n.Name Like "*" & strPartialName & "*" Then
            ReDim Preserve varResult(1 To UBound(varResult) + 1)
            varResult(UBound(varResult)) = n.Name
        End If
    Else
        ReDim Preserve varResult(1 To UBound(varResult) + 1)
        varResult(UBound(varResult)) = n.Name
    End If

Next n

wbk_ListNamedRanges = varResult

End Function
Function wbk_ListNamedRangesAndAddresses(wbk As Workbook) As Variant

Dim varResult As Variant
Dim i As Long

If wbk.Names.Count = 0 Then wbk_ListNamedRangesAndAddresses = False

ReDim varResult(1 To wbk.Names.Count, 1 To 2)

For i = 1 To wbk.Names.Count
    
    varResult(1, 1) = wbk.Names(i).Name
    varResult(1, 2) = wbk.Names(i).Value

Next i

wbk_ListNamedRangesAndAddresses = varResult

End Function
Sub wbk_AddNamedRange(wbk As Workbook, strName As String, rngRange As Range)

wbk.Names.Add Name:=strName, RefersTo:=rngRange

End Sub
Function wbk_CheckIfSheetExists(wbk As Workbook, strSheetName As String) As Boolean

Dim shtTemp As Worksheet

wbk_CheckIfSheetExists = True

On Error Resume Next
Set shtTemp = wbk.Sheets(strSheetName)
If shtTemp Is Nothing Then
    wbk_CheckIfSheetExists = False
End If
On Error GoTo 0

End Function
Private Sub wbk_ShowAllSheets(wbk As Workbook)

Dim sht As Worksheet

For Each sht In wbk.Sheets

    sht.Visible = xlSheetVisible

Next sht

End Sub
' PIVOT TABLE FUNCTIONS
Function pvt_ListPivotTableDetails(wbk As Workbook) As Variant

Dim sht As Worksheet
Dim pvt As PivotTable
Dim varResult As Variant
Dim intCountPivots As Integer
Dim intCounter As Integer

For Each sht In wbk.Sheets
    For Each pvt In sht.PivotTables
        intCountPivots = intCountPivots + 1
    Next pvt
Next sht

If intCountPivots = 0 Then pvt_ListPivotTableDetails = False

ReDim varResult(1 To intCountPivots, 1 To 4)

intCounter = 1
For Each sht In wbk.Sheets
    For Each pvt In sht.PivotTables
        
        varResult(intCounter, 1) = sht.Name
        varResult(intCounter, 2) = pvt.Name
        varResult(intCounter, 3) = pvt.SourceData
        varResult(intCounter, 4) = pvt.RefreshDate
        intCounter = intCounter + 1
        
    Next pvt
Next sht

pvt_ListPivotTableDetails = varResult

End Function
Sub pvt_RefreshPivotTables(wbk As Workbook)

Dim sht As Worksheet
Dim pvt As PivotTable

For Each sht In wbk.Sheets
    For Each pvt In sht.PivotTables
        pvt.PivotCache.Refresh
    Next pvt
Next sht

End Sub
Function pvt_CheckIfPivotExists(wbk As Workbook, strSheetName As String, strPivotName As String) As Boolean

Dim pvtTemp As PivotTable

pvt_CheckIfPivotExists = False

On Error Resume Next
Set pvtTemp = wbk.Sheets(strSheetName).PivotTables(strPivotName)
If pvtTemp Is Nothing Then
    MsgBox "The pivot table " & strPivotName & " does not exist!", vbCritical, "Pivot Table not found"
    pvt_CheckIfPivotExists = False
End If
On Error GoTo 0

End Function
' APPLICATION FUNCTIONS
Function app_GetFilePath(strTitle As String) As String

Dim FD As FileDialog
Dim strItem As String

Set FD = Application.FileDialog(msoFileDialogFilePicker)

With FD

    .Title = strTitle
    .AllowMultiSelect = False
    .InitialFileName = ActiveWorkbook.Path & "\"
    
    If .Show <> -1 Then GoTo NextCode
    strItem = .SelectedItems(1)
    
End With

NextCode:
app_GetFilePath = strItem
Set FD = Nothing

End Function
Function app_CheckIfFolderExists(strPath As String) As Boolean

app_CheckIfFolderExists = True
If Len(Dir(strPath, vbDirectory)) = 0 Then
    app_CheckIfFolderExists = False
End If

End Function
Function app_CheckIfFileExists(strPath As String) As Boolean

If Len(Dir(strPath)) = 0 Then
    app_CheckIfFileExists = False
Else
    app_CheckIfFileExists = True
End If

End Function
Sub app_CreateNewFolder(strPath As String)

On Error Resume Next
MkDir strPath
If Err.Number <> 0 Then
    MsgBox "The folder " & strPath & " could not be created!"
    Err.Clear
End If
On Error GoTo 0

End Sub
Sub app_BoostPerformance(blnActivate As Boolean)

Select Case blnActivate
    Case True
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
    Case False
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlAutomatic
        Application.EnableEvents = True
End Select

End Sub
Function app_CreateTextFile(strPath As String, Optional strContent As String)

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

Dim Fileout As Object
Set Fileout = fso.CreateTextFile(strPath, True, True)

If strContent <> "" And Not IsMissing(strContent) Then

    Fileout.Write strContent
    Fileout.Close
    
End If

End Function
' ARRAY FUNCTIONS
Function arr_GetArrayDimension(varArr As Variant) As Integer

Dim i As Integer
Dim j As Integer

On Error GoTo ErrHandler:

    i = 0
    Do While True
        i = i + 1
        j = UBound(varArr, i)
    Loop
    
ErrHandler:
    arr_GetArrayDimension = i - 1
    
End Function
Function arr_ReplaceValue(varArr As Variant, strLookUpValue As String, strReplacement As String) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr) Then arr_ReplaceValue = "Provided parameter is not an array": Exit Function

Select Case arr_GetArrayDimension(varArr)

    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr(i) = Replace(CStr(varArr(i)), strLookUpValue, strReplacement, , , vbTextCompare)
        
        Next i
        
        arr_ReplaceValue = varArr
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        lngLBound2D = LBound(varArr, 2)
        lngUBound2D = UBound(varArr, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                varArr(i, j) = Replace(CStr(varArr(i, j)), strLookUpValue, strReplacement, , , vbTextCompare)
        
            Next j
        Next i
        
        arr_ReplaceValue = varArr
    
    Case Else
        arr_ReplaceValue = False: Exit Function
       
End Select

End Function
Function arr_GetValueFromArray(varArr As Variant, strLookUpValue As String, intLookUpCol As Integer, intReturnCol As Integer) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim i As Long

If Not IsArray(varArr) Then arr_GetValueFromArray = "Provided parameter is not an array": Exit Function
If intLookUpCol > UBound(varArr, 2) Then MsgBox "LookUp column number is greater than array size!": Exit Function
If intReturnCol > UBound(varArr, 2) Then MsgBox "Return column number is greater than array size!": Exit Function

Select Case arr_GetArrayDimension(varArr)

    Case 1
        arr_GetValueFromArray = "Provided array variable must have 2 dimensions!"
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If CStr(varArr(i, intLookUpCol)) = CStr(strLookUpValue) Then arr_GetValueFromArray = varArr(i, intReturnCol): Exit Function
        
        Next i
        arr_GetValueFromArray = "No Match Found!"
        

    Case Else
        arr_GetValueFromArray = "Provided array variable must have 2 dimensions!"
    
End Select

End Function
Function arr_GetValueFromArrayInStr(varArr As Variant, strLookUpValue As String, intLookUpCol As Integer, intReturnCol As Integer) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim i As Long

If Not IsArray(varArr) Then arr_GetValueFromArrayInStr = "Provided parameter is not an array": Exit Function
If intLookUpCol > UBound(varArr, 2) Then MsgBox "LookUp column number is greater than array size!": Exit Function
If intReturnCol > UBound(varArr, 2) Then MsgBox "Return column number is greater than array size!": Exit Function

Select Case arr_GetArrayDimension(varArr)

    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If InStr(1, CStr(UCase(varArr(i))), UCase(strLookUpValue), vbTextCompare) > 0 Then arr_GetValueFromArrayInStr = varArr(i): Exit Function

        Next i
        arr_GetValueFromArrayInStr = "No Match Found!"
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If InStr(1, CStr(UCase(varArr(i, intLookUpCol))), UCase(strLookUpValue), vbTextCompare) > 0 Then arr_GetValueFromArrayInStr = varArr(i, intReturnCol): Exit Function
        
        Next i
        arr_GetValueFromArrayInStr = "No Match Found!"

    Case Else
        arr_GetValueFromArrayInStr = "Provided array variable must have 2 dimensions!"
    
End Select

End Function
Function arr_SumArrays(varArr1 As Variant, varArr2 As Variant, varArr3 As Variant) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr1) Then arr_SumArrays = False: Exit Function
If Not IsArray(varArr2) Then arr_SumArrays = False: Exit Function
If Not IsArray(varArr3) Then arr_SumArrays = False: Exit Function
If arr_GetArrayDimension(varArr1) <> arr_GetArrayDimension(varArr2) Then arr_SumArrays = False: Exit Function
If arr_GetArrayDimension(varArr1) <> arr_GetArrayDimension(varArr3) Then arr_SumArrays = False: Exit Function

Select Case arr_GetArrayDimension(varArr1)

    Case 1
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then arr_SumArrays = False: Exit Function
        If UBound(varArr1, 1) <> UBound(varArr3, 1) Then arr_SumArrays = False: Exit Function
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) + varArr2(i) + varArr3(i)
        
        Next i
        
        arr_SumArrays = varArr1
    
    Case 2
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then arr_SumArrays = False: Exit Function
        If UBound(varArr1, 1) <> UBound(varArr3, 1) Then arr_SumArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr2, 2) Then arr_SumArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr3, 2) Then arr_SumArrays = False: Exit Function
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        lngLBound2D = LBound(varArr1, 2)
        lngUBound2D = UBound(varArr1, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                varArr1(i, j) = varArr1(i, j) + varArr2(i, j) + varArr3(i, j)
        
            Next j
        Next i
        
        arr_SumArrays = varArr1
    
    Case Else
        arr_SumArrays = False: Exit Function
       
End Select

End Function
Function arr_MultiplyArrays(varArr1 As Variant, varArr2 As Variant) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr1) Then arr_MultiplyArrays = False: Exit Function
If Not IsArray(varArr2) Then arr_MultiplyArrays = False: Exit Function
If arr_GetArrayDimension(varArr1) <> arr_GetArrayDimension(varArr2) Then arr_MultiplyArrays = False: Exit Function

Select Case arr_GetArrayDimension(varArr1)

    Case 1
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then arr_MultiplyArrays = False: Exit Function
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) * varArr2(i)
        
        Next i
        
        arr_MultiplyArrays = varArr1
    
    Case 2
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then arr_MultiplyArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr2, 2) Then arr_MultiplyArrays = False: Exit Function
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        lngLBound2D = LBound(varArr1, 2)
        lngUBound2D = UBound(varArr1, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                varArr1(i, j) = varArr1(i, j) * varArr2(i, j)
        
            Next j
        Next i
        
        arr_MultiplyArrays = varArr1
    
    Case Else
        arr_MultiplyArrays = False: Exit Function
       
End Select

End Function
Function arr_MultiplyArrayBy(varArr1 As Variant, dblMultiplier As Double) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr1) Then arr_MultiplyArrayBy = False: Exit Function

Select Case arr_GetArrayDimension(varArr1)

    Case 1
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) * dblMultiplier
        
        Next i
        
        arr_MultiplyArrayBy = varArr1
    
    Case 2
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        lngLBound2D = LBound(varArr1, 2)
        lngUBound2D = UBound(varArr1, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                varArr1(i, j) = varArr1(i, j) * dblMultiplier
        
            Next j
        Next i
        
        arr_MultiplyArrayBy = varArr1
    
    Case Else
        arr_MultiplyArrayBy = False: Exit Function
       
End Select

End Function
Function arr_DivideArrayBy(varArr1 As Variant, dblMultiplier As Double) As Variant

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr1) Then arr_DivideArrayBy = False: Exit Function

Select Case arr_GetArrayDimension(varArr1)

    Case 1
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) / dblMultiplier
        
        Next i
        
        arr_DivideArrayBy = varArr1
    
    Case 2
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        lngLBound2D = LBound(varArr1, 2)
        lngUBound2D = UBound(varArr1, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                On Error Resume Next
                varArr1(i, j) = varArr1(i, j) / dblMultiplier
                If Err.Number <> 0 Then varArr1(i, j) = 0
                On Error GoTo 0
        
            Next j
        Next i
        
        arr_DivideArrayBy = varArr1
    
    Case Else
        arr_DivideArrayBy = False: Exit Function
       
End Select

End Function
Function arr_CheckIfInArray(varArr As Variant, strLookUpValue As String) As Boolean

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr) Then arr_CheckIfInArray = False: Exit Function

Select Case arr_GetArrayDimension(varArr)

    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If CStr(varArr(i)) = CStr(strLookUpValue) Then arr_CheckIfInArray = True: Exit Function
        
        Next i
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        lngLBound2D = LBound(varArr, 2)
        lngUBound2D = UBound(varArr, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                If CStr(varArr(i, j)) = CStr(strLookUpValue) Then arr_CheckIfInArray = True: Exit Function
        
            Next j
        Next i
       
    Case Else
        arr_CheckIfInArray = False: Exit Function

End Select

End Function
Function arr_CheckIfInArrayInStr(varArr As Variant, strLookUpValue As String) As Boolean

Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long

If Not IsArray(varArr) Then arr_CheckIfInArrayInStr = False: Exit Function

Select Case arr_GetArrayDimension(varArr)

    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If InStr(1, CStr(UCase(varArr(i))), UCase(strLookUpValue), vbTextCompare) > 0 Then arr_CheckIfInArrayInStr = True: Exit Function
        
        Next i
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        lngLBound2D = LBound(varArr, 2)
        lngUBound2D = UBound(varArr, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                If InStr(1, CStr(UCase(varArr(i, j))), UCase(strLookUpValue), vbTextCompare) > 0 Then arr_CheckIfInArrayInStr = True: Exit Function
        
            Next j
        Next i
       
    Case Else
        arr_CheckIfInArrayInStr = False: Exit Function

End Select

End Function
Function arr_GetUniqueRecords(varArrData As Variant) As Variant

Dim varTempArr As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim blnMatch As Boolean

If Not IsArray(varArrData) Then arr_GetUniqueRecords = False: Exit Function

ReDim varTempArr(0 To 0)

Select Case Me.arr_GetArrayDimension(varArrData)

    Case 1
        For i = LBound(varArrData) To UBound(varArrData)
        
            blnMatch = False    'reset match flag
            For k = LBound(varTempArr) To UBound(varTempArr)
                If varArrData(i) = varTempArr(k) Then blnMatch = True: Exit For
            Next k
            
            If Not blnMatch Then    'if there is no match
                ReDim Preserve varTempArr(1 To UBound(varTempArr) + 1)
                varTempArr(UBound(varTempArr)) = varArrData(i)
            End If
        
        Next i
    
    Case 2
        For i = LBound(varArrData, 1) To UBound(varArrData, 1)
            For j = LBound(varArrData, 2) To UBound(varArrData, 2)
        
                blnMatch = False    'reset match flag
                For k = LBound(varTempArr) To UBound(varTempArr)
                    If varArrData(i, j) = varTempArr(k) Then blnMatch = True: Exit For
                Next k
                
                If Not blnMatch Then    'if there is no match
                    ReDim Preserve varTempArr(1 To UBound(varTempArr) + 1)
                    varTempArr(UBound(varTempArr)) = varArrData(i, j)
                End If
        
            Next j
        Next i
    
End Select

arr_GetUniqueRecords = varTempArr

End Function
Function arr_ArrayToTextString(varArrData As Variant, strDelimiter As String) As String

Dim varTempArr As Variant
Dim i As Long
Dim j As Long

If Not IsArray(varArrData) Then arr_ArrayToTextString = False: Exit Function

ReDim varTempArr(0 To 0)

Select Case Me.arr_GetArrayDimension(varArrData)

    Case 1
        For i = LBound(varArrData) To UBound(varArrData)
            ReDim Preserve varTempArr(1 To UBound(varTempArr) + 1)
            varTempArr(UBound(varTempArr)) = varArrData(i)
        Next i
    
    Case 2
        For i = LBound(varArrData, 1) To UBound(varArrData, 1)
            For j = LBound(varArrData, 2) To UBound(varArrData, 2)
                ReDim Preserve varTempArr(1 To UBound(varTempArr) + 1)
                varTempArr(UBound(varTempArr)) = varArrData(i, j)
            Next j
        Next i

End Select

arr_ArrayToTextString = Join(varTempArr, strDelimiter)

End Function
Function arr_SortArray(varDataArray As Variant, varHeadersArray As Variant, strSortFieldName As String, SortMethod As AscendingDescending) As Variant

Dim varResultArray As Variant
Dim rstTemp As ADODB.Recordset
Dim lngRecordCount As Long
Dim intColumnCount As Integer
Dim i As Long
Dim j As Integer
Dim arrFields As Variant
Dim arrRecord As Variant
Dim strSort As String

'important
'varDataArray should include only records, header should be excluded
'varHeadersArray should include header names and data types
'shape of varHeadersArray must be as described below:
'UBound of 1st dimension defines number of columns therefore should be in line with varDataArray 2nd Ubound
'varHeadersArray 2nd dimension sotores column properties: name, data type, max lengt

'Data Types
'
'adBigInt 20
'adBinary 128
'adBoolean 11
'adChar 129
'adCurrency 6
'adDate 7
'adDBTimeStamp 135
'adDecimal 14
'adDouble 5
'adGUID 72
'adIDispatch 9
'adInteger 3
'adLongVarBinary 205
'adLongVarChar 201
'adLongVarWChar 203
'adNumeric 131
'adSingle 4
'adSmallInt 2
'adUnsignedTinyInt 17
'adVarBinary 204
'adVarChar 200
'adVariant 12
'adVarWChar 202
'adWChar 130

If Not IsArray(varHeadersArray) Then MsgBox "varHeadersArray is not an array!": Exit Function
If Not IsArray(varDataArray) Then MsgBox "varDataArray is not an array!": Exit Function

If UBound(varHeadersArray, 1) <> UBound(varDataArray, 2) Then
    MsgBox "1st dimension of varHeadersArray is different than 2nd dimension of varDataArray. Unable to sort provided array!"
    Exit Function: arr_SortArray = False
End If

'convert sort method
Select Case SortMethod
    Case Ascending
        strSort = "ASC"
    Case Descending
        strSort = "DESC"
End Select

'prepare temporary ADO recordset, add header properties
Select Case Me.arr_GetArrayDimension(varHeadersArray)

    Case 1
        MsgBox "Provided header array must be 2-dimension!"
        arr_SortArray = False: Exit Function
        
    Case 2
        Set rstTemp = New ADODB.Recordset
        With rstTemp

            For i = LBound(varHeadersArray, 1) To UBound(varHeadersArray, 1)    'for each record in 1st dimension
                .Fields.Append varHeadersArray(i, 1), varHeadersArray(i, 2), varHeadersArray(i, 3), adFldMayBeNull
            Next i

            .CursorType = adOpenKeyset
            .CursorLocation = adUseClient
            .LockType = adLockPessimistic
            .Open

        End With
        
        'create headers array
        ReDim arrFields(1 To UBound(varHeadersArray, 1))
        For j = LBound(varHeadersArray, 1) To UBound(varHeadersArray, 1)
            arrFields(j) = varHeadersArray(j, 1)
        Next j

End Select

'add records
lngRecordCount = UBound(varDataArray, 1)
intColumnCount = UBound(varDataArray, 2)

'insert new values
For i = LBound(varDataArray, 1) To UBound(varDataArray, 1)
        
    ReDim arrRecord(1 To UBound(varDataArray, 2))
    For j = LBound(varDataArray, 2) To UBound(varDataArray, 2)
        arrRecord(j) = varDataArray(i, j)
    Next j
                
    rstTemp.AddNew arrFields, arrRecord
    rstTemp.Update
        
Next i
        
rstTemp.Sort = strSortFieldName & " " & strSort
rstTemp.MoveFirst
        
varResultArray = rstTemp.GetRows

Set rstTemp = Nothing
arr_SortArray = arr_TransposeArray(varResultArray)

End Function
Function arr_TransposeArray(varArray As Variant) As Variant

Dim i As Long
Dim j As Long
Dim lngXupper As Long
Dim lngYupper As Long
Dim lngXlower As Long
Dim lngYlower As Long
Dim varTempArray As Variant

lngXlower = LBound(varArray, 2)
lngYlower = LBound(varArray, 1)
lngXupper = UBound(varArray, 2)
lngYupper = UBound(varArray, 1)

ReDim varTempArray(lngXlower To lngXupper, lngYlower To lngYupper)

For i = lngXlower To lngXupper
    For j = lngYlower To lngYupper
        varTempArray(i, j) = varArray(j, i)
    Next j
Next i

arr_TransposeArray = varTempArray
    
End Function
' SHEET FUNCTIONS
Function sht_FindLastRow(sht As Worksheet, intColToCheck) As Long

sht_FindLastRow = sht.Cells(sht.Rows.Count, intColToCheck).End(xlUp).Row

End Function
Function sht_FindLastColumn(sht As Worksheet, intRowToCheck) As Long

sht_FindLastColumn = sht.Cells(intRowToCheck, sht.Columns.Count).End(xlToRight).Row

End Function
Function sht_ColumnCountA(sht As Worksheet, intColToCheck) As Long

sht_ColumnCountA = WorksheetFunction.CountA(sht.Columns(intColToCheck))

End Function
Function sht_FindRowCol(strSearchVal As String, rngToSearch As Range, rcColRow As RowCol, pwMatch As PartialWholeMatch, Optional rngAfterCell As Range) As Long

If Not rngAfterCell Is Nothing Then
    Select Case rcColRow
        Case 1
            On Error Resume Next
            sht_FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch, After:=rngAfterCell).Row
            On Error GoTo 0
        Case 2
            On Error Resume Next
            sht_FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch, After:=rngAfterCell).Column
            On Error GoTo 0
    End Select
Else
    Select Case rcColRow
        Case 1
            On Error Resume Next
            sht_FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch).Row
            On Error GoTo 0
        Case 2
            On Error Resume Next
            sht_FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch).Column
            On Error GoTo 0
    End Select
End If

End Function
Function sht_GetColumnToArray(sht As Worksheet, strHeaderName As String, intHeaderRow As Integer, lngRawDataRecordCount As Long) As Variant

Dim intCol As Integer

With sht

    intCol = Me.sht_FindRowCol(strHeaderName, .Range(.Cells(intHeaderRow, 1), .Cells(intHeaderRow, WorksheetFunction.CountA(.Rows(intHeaderRow)))), FindColumn, WholeMatch)

    If intCol <> 0 Then
    
        sht_GetColumnToArray = .Range(.Cells(intHeaderRow + 1, intCol), .Cells(lngRawDataRecordCount, intCol)).Value
        Exit Function
    
    End If
           
End With

End Function
Function sht_NamedRangeHeaders(strRangeName As String) As Variant

Dim rngRange As Range
Dim i As Integer
Dim varResult As Variant

Set rngRange = Range(strRangeName)
ReDim varResult(1 To rngRange.Columns.Count)

For i = 1 To rngRange.Columns.Count

    varResult(i) = rngRange.Value2(1, i)

Next i

Set rngRange = Nothing

sht_NamedRangeHeaders = varResult

End Function
Function sht_ReplaceBlankNull(varValue As Variant, strReplacement) As String

If varValue = "" Or IsNull(varValue) Then
    sht_ReplaceBlankNull = strReplacement
Else
    sht_ReplaceBlankNull = varValue
End If

End Function
Function sht_GetWorksheetByCodeName(ByRef wbk As Workbook, strCodeName As String) As Worksheet

Dim sht As Worksheet

On Error GoTo ErrHandler
    
    For Each sht In wbk.Sheets
    
        If StrComp(sht.codeName, strCodeName) = 0 Then
        
            Set sht_GetWorksheetByCodeName = sht
            Exit Function
            
        End If
    
    Next sht
    
ErrHandler:
    MsgBox "Unable to find the sheet by code name " & strCodeName
    sht_GetWorksheetByCodeName = Nothing
    
End Function

'COLLECTION FUNCTIONS
Function col_CollectionContains(col As collection, strKey As String) As Boolean

On Error Resume Next
col (strKey)
col_CollectionContains = (Err.Number = 0)
Err.Clear
On Error GoTo 0

End Function
Function col_ArrayToCollection(varArr As Variant, intItemCol As Integer, intKeyCol As Integer) As collection

Dim colOutput As collection
Dim i As Long

If Not IsArray(varArr) Then MsgBox "Provided value is not an array!": Exit Function
If UBound(varArr, 2) - LBound(varArr, 2) <> 1 Then MsgBox "": Exit Function

Set colOutput = New collection

Select Case Me.arr_GetArrayDimension(varArr)

    Case 1
        MsgBox "Provided value must be 2-dimension array!": Exit Function
    
    Case 2
        For i = LBound(varArr, 1) To UBound(varArr, 1)
        
            colOutput.Add varArr(i, intItemCol), CStr(varArr(i, intKeyCol))
        
        Next i
    
    Case Else
        MsgBox "Provided value must be 2-dimension array!": Exit Function

End Select

Set col_ArrayToCollection = colOutput

End Function
Function col_GetValueFromCollection(col As collection, strKey As String) As Variant

On Error GoTo ErrorHandler

If VarType(col.Item(Trim(strKey))) = vbObject Then
    Set col_GetValueFromCollection = col.Item(Trim(strKey))
    Exit Function
Else
    col_GetValueFromCollection = col.Item(Trim(strKey))
    Exit Function
End If

ErrorHandler:
    col_GetValueFromCollection = Empty
    
End Function
Sub col_UpdateItemInCollection(ByRef col As collection, strKey As String, varValue As Variant)

If Me.col_CollectionContains(col, strKey) Then

    col.Remove strKey
    col.Add varValue, strKey
    
Else
    MsgBox "Unable to find provided key in collection!"
End If

End Sub
Sub col_RemoveAllItemsFromCollection(ByRef col As collection)

Dim i As Long

For i = col.Count To 1 Step -1

    col.Remove i

Next i

End Sub

'DICTIONARIES
Function dict_ArrayToDictionary(varArr As Variant, intItemCol As Integer, intKeyCol As Integer) As Dictionary

Dim outDict As Dictionary
Dim i As Long

If Not IsArray(varArr) Then MsgBox "Provided value is not an array!": Exit Function
If UBound(varArr, 2) - LBound(varArr, 2) <> 1 Then MsgBox "": Exit Function

Set outDict = CreateObject("scripting.dictionary")

Select Case Me.arr_GetArrayDimension(varArr)

    Case 1
        MsgBox "Provided value must be 2-dimension array!": Exit Function
    
    Case 2
        For i = LBound(varArr, 1) To UBound(varArr, 1)
        
            outDict.Add varArr(i, intItemCol), CStr(varArr(i, intKeyCol))
        
        Next i
    
    Case Else
        MsgBox "Provided value must be 2-dimension array!": Exit Function

End Select

Set dict_ArrayToDictionary = outDict

End Function