Excel VBA custom functions

Option Explicit
'character set for non ascii non printable characters
Private Const REGEX_ASCII_NON_PRINTABLE_PATTERN = "[\u0007-\u001F]"

'character set for non-ascii characters
Private Const REGEX_UNICODE_PATTERN = "[^\u0000-\u007F]"

Sub copyVisibleCells(rng As Range, destWorksheet As Worksheet)
    'Select visible cells in a range and paste only the visible cells to another worksheet
    rng.Select
    Selection.SpecialCells(xlCellTypeVisible).Select

    'Copy Visible cells only in the range and paste in target sheet
    Selection.Copy
    destWorksheet.Select
    destWorksheet.Paste
End Sub

Sub copyVisibleCellsEnd(rng As Range, destWorksheet As Worksheet)
    'Select visible cells in a range and paste only the visible cells to last row of worksheet
    Dim rowIndex As Long

    If getVisibleRowCount(rng) = 1 Then
        'exit sub if there is only a header and then select the destination worksheet
        destWorksheet.Select
        Exit Sub
    End If

    Set rng = rng.Offset(1).Resize(rng.Rows.count - 1)


    rng.SpecialCells(xlCellTypeVisible).Select
    'Copy Visible cells only in the range and paste in target sheet
    Selection.Copy
    rowIndex = destWorksheet.Range("A1").CurrentRegion.Rows.count + 1
    destWorksheet.Select
    destWorksheet.Range("A" & rowIndex).Select
    destWorksheet.Paste
End Sub

Function getColumnCount(rng As Range) As Long
'return the number of columns from a range
    getColumnCount = rng.Columns.count
End Function

Function getRowCount(rng As Range) As Long
'returns the number of rows from a range
    getRowCount = rng.Rows.count
End Function

Function getVisibleColumnCount(rng As Range) As Long
'returns the number of visible columns from a range
    Dim cellItem As Range
    Dim count As Long
    count = 0
    For Each cellItem In rng.SpecialCells(xlCellTypeVisible).Columns
        count = count + 1
    Next cellItem
    getVisibleColumnCount = count
End Function

Function getVisibleRowCount(rng As Range) As Long
'return the number of visible rows from a range
    Dim cellItem As Range
    Dim count As Long
    count = 0
    For Each cellItem In rng.SpecialCells(xlCellTypeVisible).Rows
        count = count + 1
    Next cellItem
    getVisibleRowCount = count
End Function

Function isVisibleRowGreaterThan(rng As Range, rowCount) As Boolean
'return the number of visible rows from a range
    Dim cellItem As Range
    Dim count As Long
    Dim isGreater As Boolean
    count = 0
    isGreater = False
    For Each cellItem In rng.SpecialCells(xlCellTypeVisible).Rows
        count = count + 1
        If count > rowCount Then
            isGreater = True
            Exit For
        End If
    Next cellItem
    isVisibleRowGreaterThan = isGreater
End Function

Function fileExists(file As String) As Boolean
'check if a file exists returns true if yes and false if not
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    fileExists = fso.fileExists(file)
    Set fso = Nothing
End Function

Function folderExists(Path As String) As Boolean
'check if a folder exists or not returns true if exisit and false if not
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderExists = fso.folderExists(Path)
    Set fso = Nothing
End Function

Function moveFile(filePath As String, fileDest As String) As Boolean
'move file to new location of the file does not exists
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fileExists(filePath) Then
        If Not fileExists(fileDest) Then
            Call fso.moveFile(filePath, fileDest)
        End If
    End If
End Function
 Function getFileCount(psPath As String) As Long
'strive4peace
'uses Late Binding. Reference for Early Binding:
'  Microsoft Scripting Runtime
   'PARAMETER
   '  psPath is folder to get the number of files for
   '     for example, c:\myPath
   ' Return: Long
   '    -1 = path not valid
   '     0 = no files found, but path is valid
   '    99 = number of files where 99 is some number

   'inialize return value
   getFileCount = -1
   'skip errors
   On Error Resume Next
   'count files in folder of FileSystemObject for path
   With CreateObject("Scripting.FileSystemObject")
      getFileCount = .GetFolder(psPath).Files.count
   End With
End Function

Function getFileNamesFromPath(Path As String, Optional ext As String = "", Optional excludePrefix As String = "") As Collection
'returns filenames from a folder path
'if ext is not empty then filter file names by file extension. Example of ext parameter file extension strings docx, exe
'if excludePrefix is not empty exclude all files from folder that begins with the prefix string
    Dim col As New Collection
    Dim filename As String

    'remove trailing spaces from path
    Path = Trim(Path)

    'exit function if the path does not exists
    If Path = "" Then
        Set getFileNamesFromPath = col
        Exit Function
    End If

    'add trailing space to path if the path if there is no trialing space
    If Not regexTest(Path, "\\$") Then
         Path = Path & "\"
    End If

    'filter not filter by file extension
    If ext <> "" Then
        filename = Dir(Path & "*." & ext, vbNormal & vbHidden)
    Else
        filename = Dir(Path, vbNormal & vbHidden)
    End If

    'add files names to collection and exclude files with a certain prefix if excludePrefix is not a empty string
    Do While filename <> ""
        If excludePrefix <> "" Then
            If InStr(1, filename, excludePrefix) = 0 Then
                col.Add filename
            End If
        Else
            col.Add filename
        End If
        filename = Dir
    Loop

    Set getFileNamesFromPath = col
End Function

Function deleteFolder(folderPath As String) As Boolean
'delete a folder from folder path
'this function deletes empty or non empty folder
'the function will failed if there is a permission access issue else returns true
'if the folder does not exists true is returned
    Dim fso As Object
    Dim tempPath As String
    tempPath = Trim(folderPath)
    If tempPath <> "" Then
        If Right(tempPath, 1) = "\" Then
            tempPath = Left(tempPath, Len(tempPath) - 1)
        End If
    End If

    On Error GoTo errHandler:
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.folderExists(tempPath) Then
        Call fso.deleteFolder(tempPath)
    End If

    deleteFolder = True
exitSuccess:
    Exit Function
errHandler:
    Debug.Print Err.number, Err.Description
    GoTo exitSuccess
End Function

Function getFolderCount(psPath As String) As Long
'strive4peace
'uses Late Binding. Reference for Early Binding:
'  Microsoft Scripting Runtime
   'PARAMETER
   '  psPath is path to get the number of folders for
   '     for example, c:\myPath
   ' Return: Long
   '  -1 = path not valid
   '   0 = no folders found, but path is valid
   '  99 = number of folders where 99 is some number

   'inialize return value
   getFolderCount = -1
   'skip errors
   On Error Resume Next
   'count SubFolders in FileSystemObject for psPath
   With CreateObject("Scripting.FileSystemObject")
      getFolderCount = .GetFolder(psPath).SubFolders.count
   End With
End Function

Function columnNumToColumnLetter(colNum As Long) As String
'returns an excel column letter from the number number
'if the column letter cannot be determine returns vbnullstring
    Dim regex As Object
    Dim Matches As Object
    Dim addr As String
    Set regex = CreateObject("VBScript.RegExp")
    regex.pattern = "[A-Z]+"
    addr = Cells(1, colNum).Address(False, False)
    If regex.test(addr) Then
        Set Matches = regex.Execute(addr)
        columnNumToColumnLetter = Matches(0)
    Else
        columnNumToColumnLetter = ""
    End If
    Set regex = Nothing
    Set Matches = Nothing
End Function

Sub deleteRowIfCellBlank(rng As Range)
'delete the entire row if any cells are blank
    On Error Resume Next

    rng.Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Function getColumnIndex(rng As Range, heading As String, Optional ColumnLetter As Boolean = False) As Variant
'returns heading column letter or number if the header is found else returns 0
'if ColumnLetter is true a letter is return if the column is found else 0
    Dim title As Range
    Dim HEADER As Range
    Set title = rng.Rows(1)
    For Each HEADER In title.Cells
        If StrComp(HEADER.Value, heading, vbTextCompare) = 0 Then
            If ColumnLetter = False Then
                getColumnIndex = HEADER.Column
            Else
                getColumnIndex = columnNumToColumnLetter(HEADER.Column)
            End If
            Exit Function
        End If

    Next HEADER
    getColumnIndex = 0
    Set title = Nothing
End Function

Function rangeToArray(rng As Range) As Variant
'returns a range of values as an array

    ' Declare dynamic array
    Dim tempArray As Variant

    ' tempArray values into array from first row
    rangeToArray = rng.Value
End Function

Sub arrayToRange(arr As Variant, rng As Range)
'copies array values to a range
'example Range("A1:C1] = Array[1,2,3]
    rng.Value = arr
End Sub

Function worksheetExists(sheetName As String) As Boolean
'checks active workbook if a worksheet exists
    Dim ws As Worksheet
      For Each ws In Application.ActiveWorkbook.Worksheets
        If sheetName = ws.Name Then
          worksheetExists = True
          Exit For
        End If
      Next ws
End Function

Function worksheetDelete(sheetName As String) As Boolean
'delete worksheet if the workseet exists in the active workbook by worksheet name
    If worksheetExists(sheetName) Then
        ActiveWorkbook.Worksheets(sheetName).Delete
    End If
    worksheetDelete = True
End Function

Function worksheetCreate(sheetName As String, Optional sheetIndex As Integer = 0) As Worksheet
' create a worksheet with provided sheetname in active workbook
    Dim objSheet As Object
    On Error GoTo errHandler
    If sheetIndex = 0 Then
        sheetIndex = Sheets.count
    End If
    Set objSheet = Sheets.Add(After:=Sheets(sheetIndex))
    objSheet.Name = sheetName
    Set worksheetCreate = objSheet
    Exit Function
errHandler:
    Debug.Print Err.number, Err.Description
End Function

Function worksheetCopy(wsName As String, Optional wbPath = "", Optional newWsName = "") As Boolean
'copies a worksheet from within the same workbook or from an external workbook
'if newWsName is not an empty string the copied worksheet is renamed to the newWsName
    Dim tempActiveWorkbook As Workbook, wbExternal As Workbook
    On Error GoTo errHandler
    Set tempActiveWorkbook = ActiveWorkbook
    'delete sales force worksheet if it already exists
    If wbPath <> "" Then
        Set wbExternal = Workbooks.Open(filename:=wbPath)
        wbExternal.Sheets(wsName).Copy After:=Workbooks(tempActiveWorkbook.Name).Sheets(tempActiveWorkbook.Sheets.count)
        wbExternal.Close SaveChanges:=False
    Else
        tempActiveWorkbook.Sheets(wsName).Copy After:=Workbooks(tempActiveWorkbook.Name).Sheets(tempActiveWorkbook.Sheets.count)
    End If

    If newWsName <> "" Then
        tempActiveWorkbook.ActiveSheet.Name = newWsName
    End If

    worksheetCopy = True
exitSuccess:
    Set tempActiveWorkbook = Nothing
    Set wbExternal = Nothing
    Exit Function
errHandler:
    MsgBox Err.Description
    Resume exitSuccess
End Function

Sub worksheetUnhideAllRows(Optional ws As Worksheet)
'unhide all rows in a worksheet
'if no worksheet is provided then the active worksheet is used
If ws Is Nothing Then
    Set ws = ActiveSheet
End If
    ws.Rows.EntireRow.Hidden = False
End Sub

Sub worksheetUnhideAllColumns(Optional ws As Worksheet)
'unhide all columns in a worksheet
'if no worksheet is provided then the active worksheet is used
If ws Is Nothing Then
    Set ws = ActiveSheet
End If
    ws.Rows.EntireColumn.Hidden = False
End Sub

Sub worksheetUnhideAllRowsAndColumns(Optional ws As Worksheet)
'unhide all rows and columns in a worksheet
'if no worksheet is provided then the active worksheet is used
If ws Is Nothing Then
    Set ws = ActiveSheet
End If
    Call worksheetUnhideAllRows(ws)
    Call worksheetUnhideAllColumns(ws)
End Sub

Function worksheetIsFilterMode(Optional ws As Worksheet) As Boolean
'returns true if a worksheet has a filter applied else false
'if no worksheet is provided teh active worksheet is used
    If ws Is Nothing Then
        Set ws = ActiveSheet
    End If
    worksheetIsFilterMode = ws.FilterMode
End Function

Sub worksheetClearFilter(Optional ws As Worksheet)
'unfilter a worksheet if it worksheet is filtered
'if no worksheet is provided teh active worksheet is used
If ws Is Nothing Then
        Set ws = ActiveSheet
    End If
    If worksheetIsFilterMode(ws) Then
        ws.ShowAllData
    End If
End Sub

Sub worksheetShowAllData(Optional ws As Worksheet)
'unhides all rows, columns and remove filters from a worksheet
'if no worksheet is provided the active worksheet is used
    If worksheetIsFilterMode(ws) Then
        ws.ShowAllData
    End If
    Call worksheetUnhideAllRowsAndColumns
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'             String Functions Section              '
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'ASCII char URL https://www.ibm.com/support/knowledgecenter/en/ssw_aix_72/com.ibm.aix.networkcomm/conversion_table.htm


Public Function regexTest(strData As String, pattern As String, Optional isGlobal As Boolean = True, Optional isIgnoreCase As Boolean = True, Optional isMultiLine As Boolean = True) As Boolean
'returns true if a pattern match else false

Dim objRegex As Object

On Error GoTo errHandler

Set objRegex = CreateObject("vbScript.regExp")
With objRegex
    .Global = isGlobal
    .ignoreCase = isIgnoreCase
    .MultiLine = isMultiLine
    .pattern = pattern
    'if the pattern is a match then replace the text else return the orginal string
    If .test(strData) Then
        regexTest = True
    Else
        regexTest = False
    End If
End With
exitSuccess:
    Set objRegex = Nothing
    Exit Function
errHandler:
    regexTest = False
    Debug.Print Err.Description
    Resume exitSuccess
End Function

Function regexMatches(data As String, pattern As String, Optional ignoreCase As Boolean = True, Optional globalMatches As Boolean = True) As Collection
'return a collection found from a pattern using regular expressions

    Dim regex As Object, theMatches As Object, match As Object
    Dim col As New Collection
    Set regex = CreateObject("vbScript.regExp")

    regex.pattern = pattern
    regex.Global = globalMatches
    regex.ignoreCase = ignoreCase

    Set theMatches = regex.Execute(data)

    For Each match In theMatches
      col.Add match.Value
    Next

    Set regexMatches = col
End Function

Function regexFirstMatch(data As String, pattern As String, Optional ignoreCase As Boolean = True, Optional globalMatches As Boolean = True) As String
'returns the first match from a regular expression pattern

    Dim regex As Object, theMatches As Object, match As Object
    Set regex = CreateObject("vbScript.regExp")

    regex.pattern = pattern
    regex.Global = globalMatches
    regex.ignoreCase = ignoreCase

    Set theMatches = regex.Execute(data)

    For Each match In theMatches
      regexFirstMatch = match.Value
      Exit For
    Next

End Function

Function regexReplace(strData As String, pattern As String, Optional replace_with_str = vbNullString, Optional isGlobal As Boolean = True, Optional isIgnoreCase As Boolean = True, Optional isMultiLine As Boolean = True) As String
'returns string replacing data using a regex pattern

    Dim objRegex As Object

On Error GoTo errHandler
    Set objRegex = CreateObject("vbScript.regExp")
    With objRegex
        .Global = isGlobal
        .ignoreCase = isIgnoreCase
        .MultiLine = isMultiLine
        .pattern = pattern
        'if the pattern is a match then replace the text else return the orginal string
        If .test(strData) Then
            regexReplace = .Replace(strData, replace_with_str)
        Else
            regexReplace = strData
        End If
    End With
exitSuccess:
    Set objRegex = Nothing
    Exit Function
errHandler:
    regexReplace = strData
    Debug.Print Err.Description
    Resume exitSuccess
End Function

Function regexPatternCount(strData As String, pattern As String, Optional isGlobal As Boolean = True, Optional isIgnoreCase As Boolean = True, Optional isMultiLine As Boolean = True) As Long
'returns the number of matters matches in a string using regex
'-1 will return if there was an error

    Dim objRegex As Object
    Dim Matches As Object

On Error GoTo errHandler
    Set objRegex = CreateObject("vbScript.regExp")
    objRegex.pattern = pattern
    objRegex.Global = isGlobal
    objRegex.ignoreCase = isIgnoreCase
    objRegex.MultiLine = isMultiLine
    'Retrieve all matches
    Set Matches = objRegex.Execute(strData)
    'Return the pattern matches count
    regexPatternCount = Matches.count
exitSuccess:
    Set Matches = Nothing
    Set objRegex = Nothing
    Exit Function
errHandler:
    regexPatternCount = -1
    Resume exitSuccess
End Function

Function regexRemoveConcatDupChars(data As String) As String
'remove duplicates characters when concatenated together
    regexRemoveConcatDupChars = regexReplace(data, "(.)\1+", "$1")
End Function

Function regexContainsConcatDupChars(data As String) As Boolean
'returns true if there are concatenated characters of the same type in as string provided
    regexContainsConcatDupChars = regexPatternCount(data, "(.)\1+")
End Function

Function regexContainsNonAscii(data As String) As Boolean
'returns true if a string contains unicode characters else false
    If regexPatternCount(data, REGEX_UNICODE_PATTERN) > 0 Then
        regexContainsNonAscii = True
    Else
        regexContainsNonAscii = False
    End If
End Function

Function regexLeftTrim(data As String) As String
'returns a string removing spaces and tab characters from the beginning of a string only
    regexLeftTrim = regexReplace(data, "^[\s\t]+")
End Function

Function regexRightTrim(data As String) As String
'returns a string removing spaces and tab characters from the beginning and end of a string
    regexRightTrim = regexReplace(data, "[\s\t]+$")
End Function

Function regexTrim(data As String) As String
'returns a string removing spaces and tab characters from the beginning and end of a string
    data = regexLeftTrim(data)
    data = regexRightTrim(data)
    regexTrim = data
End Function

Function setFirstLetterCapitalized(data As String) As String
'returns a string with first letter capitialize
    If Len(data) = 0 Then
        setFirstLetterCapitalized = ""
    Else
        setFirstLetterCapitalized = UCase(Mid(data, 1, 1)) & Mid(data, 2, Len(data))
    End If
End Function

Function setProperCase(data As String) As String
'returns a string with all words starting with a capital letter and the rest lowercase
    setProperCase = StrConv(data, vbProperCase)
End Function

Function sqlStrFormat(data As String) As String
'returns a string replacing single quotes with double single quotes
    Const SINGLE_QUOTE_CHAR = "'"
    sqlStrFormat = Replace(data, SINGLE_QUOTE_CHAR, SINGLE_QUOTE_CHAR & SINGLE_QUOTE_CHAR)
End Function

Private Sub displayError(Optional toImmediateWindow As Boolean = True)
'display error code number and description in the immediate window by default
'if toImmediateWindow is false then the error is displayed in a messagebox
'this subroutine is used for ON ERROR GoTo statements error handler section
    If toImmediateWindow Then
        Debug.Print Err.number, Err.Description
    Else
        MsgBox Err.number & " " & Err.Description, vbCritical
    End If
End Sub

Function createDictionary(Optional ignoreCase As Boolean = False) As Object
'returns a dictionary object
'if ignore case is true the dictionary keys will not be case sensitive. The default is case sensitive
    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")

    If ignoreCase Then
        dict.comparemode = vbTextCompare
    End If

    Set createDictionary = dict
End Function

Function isValueInRange(rng As Range, search As String, Optional lookIn As XlFindLookIn = XlFindLookIn.xlFormulas, Optional lookAt As XlLookAt = XlLookAt.xlWhole, Optional matchCase As Boolean = False) As String
'returns string address of the cell where the value if found in the range
'if the value is not found than an empty string is returned

    Dim cell As Range

    Set cell = rng.Find(What:=search, lookIn:=lookIn, lookAt:=lookAt, matchCase:=matchCase)

    If cell Is Nothing Then
        isValueInRange = ""
    Else
        isValueInRange = cell.Address
    End If

End Function

Function countNumberOfNonBlankCells(rng As Range) As Long
'returns the count of cells that are not empty
    countNumberOfNonBlankCells = Application.WorksheetFunction.CountA(rng)
End Function

Sub quickSort(vArray As Variant, inLow As Long, inHi As Long)
'sort an array in ascending order
'example quickSort(arr, LBound(arr), UBound(arr))
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then quickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then quickSort vArray, tmpLow, inHi

End Sub

Function binarySearch(lookupArray As Variant, lookupValue As Variant) As Long
'binary search lookup for arrays
'the array must be sorted when using this function
'-1 is return if not found else the index of where the item is found

    Dim lngLower As Long
    Dim lngMiddle As Long
    Dim lngUpper As Long

    lngLower = LBound(lookupArray)
    lngUpper = UBound(lookupArray)

    Do While lngLower < lngUpper

        lngMiddle = (lngLower + lngUpper) \ 2

        If lookupValue > lookupArray(lngMiddle) Then
            lngLower = lngMiddle + 1
        Else
            lngUpper = lngMiddle
        End If

    Loop

    If lookupArray(lngLower) = lookupValue Then
        binarySearch = lngLower
    Else
        binarySearch = -1    'search does not find a match
    End If
End Function

Function collectionToArray(col As Collection) As Variant
'returns an array from a collection object
    Dim result  As Variant
    Dim cnt     As Long

    ReDim result(col.count - 1)

    For cnt = 0 To col.count - 1
        result(cnt) = col(cnt + 1)
    Next cnt

    collectionToArray = result
End Function