My VBA Functions

modUtils.bas

'  ############################ FUNCTION / PROCEDURE LIST ############################
'  ###################################################################################
'
'  1. ListNamedRanges
'        The function lists all custom named ranges. It is possible to provide optional parameter so that the function checks if validated text string contains this value
'  2. ListPivotTableDataSources
'        The procedures lists all pivot tables and their data sources
'  3. NamedRangeHeaders
'        This function returns header names for particular named range
'  4. GetFilePath
'        The function displays dialog box which allows the user to select a file. Eventually the funtions returns full path which leads to selected document.
'  5. ReplaceInArray
'        Using this function you can replace text string in single/multi-dimension array
'  6. ReturnValueFromArray
'        With this function the user can return value from single/multi-dimension array
'  7. SumArrays
'        Sum the results from 3 same size arrays
'  8. GetColumnToArray
'        This function puts the values from entire column into array
'  9. MultiplyArrays
'        Multiply the results from 2 arrays
' 10. MultiplyArrayBy
'        Multiply the array by multiplier value
' 11. DivideArrayBy
'        Divide the array by provided value
' 12. CheckIfInArray
'        Check if an array contains provided value
' 13. GetArrDimension
'        Check if array is 1 or 2 dimension
' 14. ReplaceIfBlank
'        Replace value if blank
' 15. CheckIfFolderExists
'        The function returns true/false value depending on folder existance
' 16. CreateNewFolder
'        The procedure creates a new folder in particular location
' 17. BoostPerformance
'        The procedure improves calculation performance
' 18. CheckIfSheetExists
'        The function verifies whether particular sheet can be found
' 19. FindLastRow
'        The result of this function is the number of last row
' 20. FindNonBlankRow
'        The function counts the number of non-blank records in particular column
' 21. CheckIfPivotExists
'        This function check if pivot table exists
' 22. FindRowCol
'        Multi purpose function that shows the number of row/column based on provided header/row name
' 23. ShowAllSheets
'        The procedure reveals all sheets
' 24. AddNamedRange
'        The procedure creates/updates named range
' 25. GetUniqueRecords
'        The procedures extracts unique items from an array
' 26. ArrayToTextString
'        The function combines all array values and return them as one text string.
' 27. SortArray
'        The function returns sorted array
' 28. TransposeArray
'        The function returns transposed array
' 29. CheckIfFileExists
'       The function check if file exists
' 30. CreateTextFile
'       Function creates a text file in provided location
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
Function ListNamedRanges(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 ThisWorkbook.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

ListNamedRanges = varResult

End Function
Private Sub ListPivotTableDataSources()

Dim sht As Worksheet
Dim pvt As PivotTable

For Each sht In ThisWorkbook.Sheets
    For Each pvt In sht.PivotTables
    
        Debug.Print "Sheet: " & sht.Name & ", PivotTable: " & pvt.Name & ", Source: " & pvt.SourceData
    
    Next pvt
Next sht

End Sub
Function 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

NamedRangeHeaders = varResult

Set rngRange = Nothing

End Function
Function 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:
GetFilePath = strItem
Set FD = Nothing

End Function
Function ReplaceInArray(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 ReplaceInArray = "Provided parameter is not an array": Exit Function

Select Case GetArrDimension(varArr)

    Case 1
        If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr(i) = Replace(CStr(varArr(i)), strLookUpValue, strReplacement, , , vbTextCompare)
        
        Next i
        
        ReplaceInArray = varArr
    
    Case 2
        If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
        If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
        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
        
        ReplaceInArray = varArr
    
    Case Else
        ReplaceInArray = False: Exit Function
       
End Select

End Function
Function ReturnValueFromArray(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 ReturnValueFromArray = "Provided parameter is not an array": Exit Function

Select Case GetArrDimension(varArr)

    Case 1
        ReturnValueFromArray = "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 ReturnValueFromArray = varArr(i, intReturnCol): Exit Function
        
        Next i
        ReturnValueFromArray = "No Match Found!"
        

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

End Function
Function ReturnValueFromArrayInStr(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 ReturnValueFromArrayInStr = "Provided parameter is not an array": Exit Function

Select Case GetArrDimension(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 ReturnValueFromArrayInStr = varArr(i): Exit Function

        Next i
        ReturnValueFromArrayInStr = "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 ReturnValueFromArrayInStr = varArr(i, intReturnCol): Exit Function
        
        Next i
        ReturnValueFromArrayInStr = "No Match Found!"

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

End Function
Function 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 SumArrays = False: Exit Function
If Not IsArray(varArr2) Then SumArrays = False: Exit Function
If Not IsArray(varArr3) Then SumArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr2) Then SumArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr3) Then SumArrays = False: Exit Function

Select Case GetArrDimension(varArr1)

    Case 1
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then SumArrays = False: Exit Function
        If UBound(varArr1, 1) <> UBound(varArr3, 1) Then 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
        
        SumArrays = varArr1
    
    Case 2
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then SumArrays = False: Exit Function
        If UBound(varArr1, 1) <> UBound(varArr3, 1) Then SumArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr2, 2) Then SumArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr3, 2) Then 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
        
        SumArrays = varArr1
    
    Case Else
        SumArrays = False: Exit Function
       
End Select

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

Dim intCol As Integer

With sht

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

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

End Function
Function 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 MultiplyArrays = False: Exit Function
If Not IsArray(varArr2) Then MultiplyArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr2) Then MultiplyArrays = False: Exit Function

Select Case GetArrDimension(varArr1)

    Case 1
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then 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
        
        MultiplyArrays = varArr1
    
    Case 2
        If UBound(varArr1, 1) <> UBound(varArr2, 1) Then MultiplyArrays = False: Exit Function
        If UBound(varArr1, 2) <> UBound(varArr2, 2) Then 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
        
        MultiplyArrays = varArr1
    
    Case Else
        MultiplyArrays = False: Exit Function
       
End Select

End Function
Function 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 MultiplyArrayBy = False: Exit Function

Select Case GetArrDimension(varArr1)

    Case 1
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) * dblMultiplier
        
        Next i
        
        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
        
        MultiplyArrayBy = varArr1
    
    Case Else
        MultiplyArrayBy = False: Exit Function
       
End Select

End Function
Function 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 DivideArrayBy = False: Exit Function

Select Case GetArrDimension(varArr1)

    Case 1
        lngLBound1D = LBound(varArr1, 1)
        lngUBound1D = UBound(varArr1, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            varArr1(i) = varArr1(i) / dblMultiplier
        
        Next i
        
        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
        
        DivideArrayBy = varArr1
    
    Case Else
        DivideArrayBy = False: Exit Function
       
End Select

End Function
Function 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 CheckIfInArray = False: Exit Function

Select Case GetArrDimension(varArr)

    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If CStr(varArr(i)) = CStr(strLookUpValue) Then 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 CheckIfInArray = True: Exit Function
        
            Next j
        Next i
       
    Case Else
        CheckIfInArray = False: Exit Function

End Select

End Function
Function 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 CheckIfInArrayInStr = False: Exit Function

Select Case GetArrDimension(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 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 CheckIfInArrayInStr = True: Exit Function
        
            Next j
        Next i
       
    Case Else
        CheckIfInArrayInStr = False: Exit Function

End Select

End Function
Function GetArrDimension(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:
    GetArrDimension = i - 1
    
End Function
Function ReplaceIfBlank(varValue As Variant, strReplacement) As String

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

End Function
Function CheckIfFolderExists(strPath As String) As Boolean

CheckIfFolderExists = True 'path exists by default
If Len(Dir(strPath, vbDirectory)) = 0 Then

    CheckIfFolderExists = False

End If

End Function
Sub 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 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 CheckIfSheetExists(strSheetName As String) As Boolean

Dim shtTemp As Worksheet

CheckIfSheetExists = True

On Error Resume Next
Set shtTemp = ThisWorkbook.Sheets(strSheetName)
If shtTemp Is Nothing Then
    MsgBox "The sheet " & strSheetName & " does not exist!", vbCritical, "Sheet not found"
    CheckIfSheetExists = False
End If
On Error GoTo 0

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

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

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

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

End Function
Function CheckIfPivotExists(strSheetName As String, strPivotName As String) As Boolean

Dim pvtTemp As PivotTable

CheckIfPivotExists = False

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

End Function
Function 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
            FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch, After:=rngAfterCell).Row
            On Error GoTo 0
    
        Case 2
        
            On Error Resume Next
            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
            FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch).Row
            On Error GoTo 0
    
        Case 2
        
            On Error Resume Next
            FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=pwMatch).Column
            On Error GoTo 0
        
    End Select
    
End If

End Function
Private Sub ShowAllSheets()

Dim sht As Worksheet

For Each sht In ThisWorkbook.Sheets

    sht.Visible = xlSheetVisible

Next sht

End Sub
Private Sub AddNamedRange(strName As String, rngRange As Range)

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

End Sub
Function 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 GetUniqueRecords = False: Exit Function

ReDim varTempArr(0 To 0)

Select Case modUtils.GetArrDimension(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

GetUniqueRecords = varTempArr

End Function
Function 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 ArrayToTextString = False: Exit Function

ReDim varTempArr(0 To 0)

Select Case modUtils.GetArrDimension(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

ArrayToTextString = Join(varTempArr, strDelimiter)

End Function
Function 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

'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 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: 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
'shape of varHeadersArray must be as described below
'UBound of 1st dimension defines number of columns
'2nd dimension sotores column properties: name, data type, max lengt
Select Case modUtils.GetArrDimension(varHeadersArray)

    Case 1
        MsgBox "Provided header array must be 2-dimension!"
        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
Select Case modUtils.GetArrDimension(varDataArray)

    Case 1
        MsgBox "Provided data array must be 2-dimension!"
        SortArray = False: Exit Function
    
    Case 2
        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

End Select

Set rstTemp = Nothing
SortArray = TransposeArray(varResultArray)

End Function
Function 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

TransposeArray = varTempArray
    
End Function
Function CheckIfFileExists(strPath As String) As Boolean

If Len(Dir(strPath)) = 0 Then

    CheckIfFileExists = False
  
Else
    
    CheckIfFileExists = True

End If

End Function
Function 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