Excel - Various User Defined Functions (VBA based)

Array UDF are marked with *. Some can act both as array and non-array, marked with **. Some can be used within standard functions such as SUM and thus convert to single cell output functions.

CONCATENATEX concatenates all values into a string with a specified separator in between (easier to implement than CONCATENATE).
GETWORD gets the n^th "word" from a string, from beginning or end.
GETWORDS * splits a string into all its "words" and gets all words or n words, starting from the m^th word, counting m from start or end. GETWORDS can do the same as GETWORD, and more. GETWORDS (retrieving words from a sentences) is 'comparable' to standard function MID (retrieving characters from a word), but works on a 'higher level'.
FINDINCELLS ** returns the (single or row/column) index or address of the first cell that contains the string to find. This function searches within cell contents of the 1 or 2-dimensional search range, unlike XLOOKUP or MATCH. You can set its search directions very precisely. By the way, using INDEX you can convert this array formula into a regular formula.
DECIMALSEPARATOR returns the decimal separator in use, so you can make TEXT functions separator independent (prevent them to fail).
GETCOLOR ** returns the single color code of a cell, or Red, Green, Blue values.
INFILTER returns the multiple values used in a filter of pivot table.
UNIQUEVALUES * returns the unique values in a range as a concatenated string or as separate values (array), unsorted or sorted. You can use standard Excel function UNIQUE (Office365/Excel 2021) for single column or row input only.
SORTRANGE * sorts a single row or single column input (QuickSort) in ascending or descending order. You can also use standard Excel function SMALL/LARGE to sort numbers, or SORT (Office365/Excel 2021). SORTRANGE combined with RANGETOLIST and LISTORANGE enable you to sort all values of a 2-dimensional range as well.
LEVENSHTEIN calculates the number of insertions, deletions, and substitutions needed to transform the first string into the second string. Good example of a very specific function that is pretty difficult and cumbersome (not entirely impossible) to realize with Excel's standard functionality.

Next 5 UDFs are merely relevant for handling hidden columns. If your case is about hidden rows only, then use standard function SUBTOTAL.

CELLVISIBLE returns TRUE if cell is visible, else FALSE. Multiplying by 1 converts TRUE/FALSE into 1/0.
SUMVISIBLE sums visible cell values.
COUNTVISIBLE counts visible cells.
AVERAGEVISIBLE averages visible cell values.
VISIBLECELLS * returns all visible cell values in a range as a list (1-dimensional array) and can be used within SUM, COUNT, AVERAGE, MAX, MEDIAN, etc., but also SORT, UNIQUE (Office365/Excel 2021) so it enables more functionality than the above 4 UDF.
More complex regular formulas may work as well, as can be seen in the demo file. If run time becomes an issue, then it is better to use regular formulas as these execute faster.

Next UDF can be considered array manipulation functions.

RANGETOLIST * returns all cell values in a range as a list (1-dimensional array). It is also a helper function that can be used within SORT and UNIQUE (Office365/Excel 2021), to retrieve all unique values from a 2-dimensional range (which UNIQUE alone cannot handle). Or with UDF SORTRANGE.
LISTTORANGE * converts a list into a range (2-dimensional), given the amount of columns to be created, and row or column fill priority.
REVERSERANGE * reverses the rows or columns of a range. REVERSERANGE within REVERSERANGE reverses both rows and columns.
EXTRACTVALUES * extracts values from all/indicated rows and all/indicated columns into a reshaped 2-dimensional range. It is a multipurpose function that enables extracting, duplicating, and resequencing data.

Also UDF of pages bilinear interpolation , linear interpolation , as-the-crow-flies distance are included. Those pages contain more info.

GLOBEDISTANCE calculates the as-the-crow-flies distance
INTERPOLATEX interpolates X on a 1-dimensional table
INTERPOLATEXY interpolates X and Y on a 2-dimensional table
SPLINES are not included.

The following are no UDF as such, but handy extra functionality. It requires a few lines of VBA code in your worksheet, to make it respond to a double click. VBA code is found below and in file.

GETFOLDER fills a cell with the folder name selected via a dialog box. Triggered by double clicking on a named cell.
GETFILE fills a cell with the file name selected via a dialog box. Triggered by double clicking on a named cell.
DATEPICKER will set the date after selecting a date from a date form. This form is triggered by double clicking on cells formatted as date.

File preview (top part only)

VBA code to be put in a module

In MS Excel, press Alt+F11 to open the Visual Basic Editor (Windows). Via top menu: Insert → Module. Copy the code below into the module.
Or export module mdlVariousUDF from the demo file and import it into your own file.

VBA code

Option Explicit

Public Function GetWord(ByVal InputString As String, ByVal Separator As String, ByVal n As Integer, Optional ByVal Backwards As Boolean)
    Dim arr As Variant
    Dim UB As Long
    arr = Split(InputString, Separator)
    UB = UBound(arr)
    If n > 0 And n - 1 <= UB Then
        If Backwards Then GetWord = arr(UB - n + 1) Else GetWord = arr(n - 1)
    Else
        GetWord = ""
    End If
End Function

Public Function GetWords(InputString, ByVal Separator As String, Optional StartFrom As Long, Optional NumWords As Variant, Optional ByVal FromEnd As Boolean)
    Dim arr
    Dim outputs()
    Dim UB As Long, upto As Long, i As Long, cnt As Long
    
    arr = Split(InputString, Separator)
    UB = UBound(arr)
    'ismissing requires optinal parameter to be variant
    If IsMissing(NumWords) Then
        NumWords = UB + 1
    Else
        If (NumWords = 0) Then NumWords = UB + 1
    End If
    If NumWords > UB Then NumWords = UB + 1
    If StartFrom > 0 Then StartFrom = StartFrom - 1 'array is numbered 0 to ...
        
    ReDim outputs(NumWords)
    cnt = 0
    If FromEnd = False Then
        For i = 0 To NumWords - 1
            If StartFrom + i > UB Then Exit For
            outputs(cnt) = arr(StartFrom + i)
            cnt = cnt + 1
        Next
    Else
        StartFrom = UB - StartFrom
        For i = 0 To NumWords - 1
            If StartFrom + i > UB Then Exit For
            If StartFrom + i >= 0 Then
                outputs(cnt) = arr(StartFrom + i)
                cnt = cnt + 1
            End If
        Next
    End If
    If cnt = 0 Then
        GetWords = ""
    Else
        ReDim Preserve outputs(cnt - 1)
        GetWords = outputs
    End If
End Function

Public Function ConcatenateX(Inputrange As Variant, ByVal Separator As String, Optional By_columns As Boolean) As String
    Dim arr As Variant
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long
    Dim concat As String
    
    'Single value exit
    If Not (IsArray(Inputrange)) Then
        ConcatenateX = Inputrange
        Exit Function
    End If
    
    arr = Inputrange
    nRows = UBound(arr) 'or SearchRange.Rows.Count
    nCols = UBound(arr, 2) 'or SearchRange.Columns.Count
    concat = ""
    
    If By_columns Then
            For iCol = 1 To nCols
            For iRow = 1 To nRows
                concat = concat & arr(iRow, iCol) & Separator
            Next
        Next
    Else
        For iRow = 1 To nRows
                For iCol = 1 To nCols
                    concat = concat & arr(iRow, iCol) & Separator
                Next
            Next
    End If
    concat = Left(concat, Len(concat) - 1)
    ConcatenateX = concat
End Function

Public Function FindInCells(ByVal SearchValue As String, SearchRange As Variant, Optional By_columns As Boolean, Optional MatchLength As Boolean, Optional MatchUpperLowercase As Boolean, Optional ReturnAddress As Boolean, Optional RowsBackwards As Boolean, Optional ColumnsBackwards As Boolean) As Variant
    Dim arr As Variant
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long
    Dim Directions As String
    Dim Columnsfirst As Boolean
    
    'Single value exit
    If Not (IsArray(SearchRange)) Then
        'done like this as several checks would make a single value exit kind of long
        ReDim arr(1, 1)
        arr(1, 1) = SearchRange
    Else
        arr = SearchRange
    End If

nRows = UBound(arr) 'or SearchRange.Rows.Count
    nCols = UBound(arr, 2) 'or SearchRange.Columns.Count
    
    'Convert to lowercase by default
    If MatchUpperLowercase = False Then
        SearchValue = LCase(SearchValue)
        For iRow = 1 To nRows
            For iCol = 1 To nCols
                arr(iRow, iCol) = LCase(arr(iRow, iCol))
            Next
        Next
    End If
    
    'Determine search directions - with NSWE and WENS put upfront
    Columnsfirst = By_columns
    If (Columnsfirst = False) And (RowsBackwards = False) And (ColumnsBackwards = False) Then
        Directions = "WENS"
    ElseIf (Columnsfirst = False) And (RowsBackwards = False) And (ColumnsBackwards = True) Then
        Directions = "WESN"
    ElseIf (Columnsfirst = False) And (RowsBackwards = True) And (ColumnsBackwards = False) Then
        Directions = "EWNS"
    ElseIf (Columnsfirst = False) And (RowsBackwards = True) And (ColumnsBackwards = True) Then
        Directions = "EWSN"
    ElseIf (Columnsfirst = True) And (RowsBackwards = False) And (ColumnsBackwards = False) Then
        Directions = "NSWE"
    ElseIf (Columnsfirst = True) And (RowsBackwards = False) And (ColumnsBackwards = True) Then
        Directions = "NSEW"
    ElseIf (Columnsfirst = True) And (RowsBackwards = True) And (ColumnsBackwards = False) Then
        Directions = "SNWE"
    ElseIf (Columnsfirst = True) And (RowsBackwards = True) And (ColumnsBackwards = True) Then
        Directions = "SNEW"
    End If
    
    Select Case Directions
        Case "NSWE":
            For iCol = 1 To nCols
                For iRow = 1 To nRows
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "NSEW":
            For iCol = nCols To 1 Step -1
                For iRow = 1 To nRows
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "SNWE":
            For iCol = 1 To nCols
                For iRow = nRows To 1 Step -1
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "SNEW":
            For iCol = nCols To 1 Step -1
                For iRow = nRows To 1 Step -1
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "WENS":
            For iRow = 1 To nRows
                For iCol = 1 To nCols
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "WESN":
            For iRow = nRows To 1 Step -1
                For iCol = 1 To nCols
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "EWNS":
            For iRow = 1 To nRows
                For iCol = nCols To 1 Step -1
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
        Case "EWSN":
            For iRow = nRows To 1 Step -1
                For iCol = nCols To 1 Step -1
                    If (InStr(arr(iRow, iCol), SearchValue) > 0) Then
                        If Not (MatchLength) Then GoTo found
                        If (MatchLength) And Len(SearchValue) = Len(arr(iRow, iCol)) Then GoTo found
                    End If
                Next
            Next
    End Select
    
    'Not found
    FindInCells = CVErr(xlErrNA)
    Exit Function

found:
    If ReturnAddress Then
        FindInCells = SearchRange.Cells(iRow, iCol).Address
    ElseIf nRows = 1 Then
        FindInCells = iCol
    ElseIf nCols = 1 Then
        FindInCells = iRow
    Else
        Dim output(1, 0)
        output(0, 0) = iRow
        output(1, 0) = iCol
        FindInCells = WorksheetFunction.Transpose(output)
    End If
     
End Function

Public Function DecimalSeparator()
    DecimalSeparator = Application.International(xlDecimalSeparator)
End Function

Public Function GetColor(Cell As Range, Optional RGB As Boolean, Optional Index As Integer)
    'Uses the next function getColorSub, so copy that one in as well
    Application.Volatile
    Dim C As Long, R As Long, G As Long, B As Long
    Dim outputs()
    ReDim outputs(0, 0 To 2)
    
    'Trick required, as .display.interior.color otherwise does not work, so call second function
    C = Cell.Parent.Evaluate("GetColorSub(""" & Cell.Address & """)")
    If RGB = True Then
        R = Round(C Mod 256, 0)
        G = Round(C \ 256 Mod 256, 0)
        B = Round(C \ 65536 Mod 256, 0)
        outputs(0, 0) = R
        outputs(0, 1) = G
        outputs(0, 2) = B
        If Index = 1 Then
            GetColor = R
        ElseIf Index = 2 Then
            GetColor = G
        ElseIf Index = 3 Then
            GetColor = B
        Else
            GetColor = outputs
        End If
    Else
        GetColor = C
    End If
End Function

Public Function GetColorSub(addr)
    GetColorSub = Range(addr).DisplayFormat.Interior.Color
End Function

Public Function InFilter(ByVal PivotTableName As String, ByVal FieldName As String, Optional Separator As String) As String
    Application.Volatile
    
    On Error GoTo exitFunction
    Dim MS As String
    Dim pt As PivotTable
    Dim pf
    Dim Pi
    Dim sep As String
    
    MS = ""
    Set pt = ThisWorkbook.ActiveSheet.PivotTables(PivotTableName)
    Set pf = pt.PageFields.Item(FieldName) 'should be the only PageField
    If Separator = "" Then sep = "|" Else sep = Separator
    For Each Pi In pf.PivotItems 'loop through the fields and find only the visible ones
       If Pi.Visible Then MS = MS & Pi.Name & sep
    Next
    InFilter = Left(MS, Len(MS) - Len(sep))
    
exitFunction:
End Function

Public Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a folder by clicking on its name"
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Public Function GetFile() As String
    On Error GoTo exitFunction
    Dim gF As String
    gF = Application.GetOpenFilename("(*.xlsb),*.xlsb", MultiSelect:=False)
    GetFile = gF
    If gF = False Then GetFile = ""
exitFunction:
End Function

Public Function Levenshtein(ByRef S1 As String, ByVal S2 As String) As Long
    'Calculate the Levenshtein Distance between two strings (the number of insertions,
    'deletions, and substitutions needed to transform the first string into the second)
    
    Dim L1 As Long, L2 As Long, D() As Long 'Length of input strings and distance matrix
    Dim i As Long, j As Long, cost As Long 'loop counters and cost of substitution for current letter
    Dim cI As Long, cD As Long, cS As Long 'cost of next Insertion, Deletion and Substitution
    L1 = Len(S1): L2 = Len(S2)
    ReDim D(0 To L1, 0 To L2)
    For i = 0 To L1: D(i, 0) = i: Next i
    For j = 0 To L2: D(0, j) = j: Next j

For j = 1 To L2
        For i = 1 To L1
            cost = Abs(StrComp(Mid$(S1, i, 1), Mid$(S2, j, 1), vbTextCompare))
            cI = D(i - 1, j) + 1
            cD = D(i, j - 1) + 1
            cS = D(i - 1, j - 1) + cost
            If cI <= cD Then 'Insertion or Substitution
                If cI <= cS Then D(i, j) = cI Else D(i, j) = cS
            Else 'Deletion or Substitution
                If cD <= cS Then D(i, j) = cD Else D(i, j) = cS
            End If
        Next i
    Next j
    Levenshtein = D(L1, L2)
End Function

Public Function UniqueValues(Inputrange As Variant, Optional Separator As String, Optional ReturnAsString As Boolean, Optional DoSort As Boolean, Optional MatchUpperLowercase As Boolean)
    'this function uses next sub QuickSort, so copy in as well
    
    Dim Dict As Object
    Dim arr As Variant
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long, i As Long
    Dim uv() As Variant
     
    'single value exit
    If Not (IsArray(Inputrange)) Then
        UniqueValues = Inputrange
        Exit Function
    End If
   
    'Convert range to array and count rows and columns
    arr = Inputrange
    nCols = UBound(arr, 2)
    nRows = UBound(arr)
    
    'Put unique data elements in a dictionay
    Set Dict = CreateObject("Scripting.Dictionary")
    For iRow = 1 To nCols
        For iCol = 1 To nRows
            If MatchUpperLowercase Then
                Dict(arr(iCol, iRow)) = 1
            Else
                Dict(LCase(arr(iCol, iRow))) = 1
            End If
        Next
    Next
    
    'Get unique values
    uv = Dict.keys
    
    'Sort array
    If DoSort Then Call QuickSort(uv, 0, UBound(uv))
    
    'Output as joined string or as transposed array
    If ReturnAsString Then
        UniqueValues = Join(uv, Separator)
    Else
        If UBound(uv) < 65536 Then
            uv = WorksheetFunction.Transpose(uv) 'transpose makes it a vertical list
            UniqueValues = uv
        Else
            Dim finalOutputs()
            ReDim finalOutputs(0 To UBound(uv), 0)
            For i = 0 To UBound(uv)
                finalOutputs(i, 0) = uv(i)
            Next
            UniqueValues = finalOutputs
        End If
    End If
        
End Function

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  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

Public Function Sortrange(Inputrange, Optional SortDescending As Boolean)
    Dim outputs()
    Dim arr As Variant
    Dim op As Long
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long
     
    'Single value exit
    If Not (IsArray(Inputrange)) Then
        Sortrange = Inputrange
        Exit Function
    End If
   
    'Put range values in list so it can be sorted
    arr = Inputrange
    nCols = UBound(arr, 2)
    nRows = UBound(arr)
    ReDim outputs(1 To nCols * nRows)
    op = 1
    For iCol = 1 To nCols
        For iRow = 1 To nRows
            If arr(iRow, iCol) = "" Then outputs(op) = "" Else outputs(op) = arr(iRow, iCol)
            op = op + 1
        Next
    Next
    op = op - 1
    
    Call QuickSort(outputs, 1, op)
    
    If SortDescending Then
        ReDim temp(1 To op)
        Dim i As Long
        For i = 1 To op
            temp(i) = outputs(op + 1 - i)
        Next
        outputs = temp
    End If
   
    'Transpose if input is column
    If nCols = 1 Then
        If nCols < 65536 Then
            Sortrange = WorksheetFunction.Transpose(outputs)
        Else
            'Work around TRANSPOSE limitation of 65536 values
            Dim finalOutputs()
            ReDim finalOutputs(1 To op, 0)
            For iRow = 1 To op
                finalOutputs(iRow, 0) = outputs(iRow)
            Next
            Sortrange = finalOutputs
        End If
    Else
        Sortrange = outputs
    End If

End Function

Public Function reverseRange(Inputrange, Optional ReverseRows As Boolean, Optional ReverseColumns As Boolean)

Dim arr As Variant
    Dim outputs(), op As Long
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long, i As Long, j As Long
    Dim hidden() As Boolean
    Dim reverseR As Boolean, reverseC As Boolean
    
    'Single cell exit
    If Not (IsArray(Inputrange)) Then
        reverseRange = Inputrange
        Exit Function
    End If
    
    arr = Inputrange
    nCols = UBound(arr, 2)
    nRows = UBound(arr)
    
    ReDim outputs(1 To nRows, 1 To nCols)
    
    reverseR = ReverseRows
    reverseC = ReverseColumns
    If (nCols = 1) Then reverseR = True
    If (nRows = 1) Then reverseC = True
    
    If reverseR And Not reverseC Then
        For iCol = 1 To nCols
            j = j + 1
            i = 0
            For iRow = nRows To 1 Step -1
                i = i + 1
                If arr(iRow, iCol) = "" Then outputs(i, j) = "" Else outputs(i, j) = arr(iRow, iCol)
            Next
        Next
    ElseIf reverseC And Not reverseR Then
        For iCol = nCols To 1 Step -1
            j = j + 1
            i = 0
            For iRow = 1 To nRows
                i = i + 1
                If arr(iRow, iCol) = "" Then outputs(i, j) = "" Else outputs(i, j) = arr(iRow, iCol)
            Next
        Next
    ElseIf reverseR And reverseC Then
        For iCol = nCols To 1 Step -1
            j = j + 1
            i = 0
            For iRow = nRows To 1 Step -1
                i = i + 1
                If arr(iRow, iCol) = "" Then outputs(i, j) = "" Else outputs(i, j) = arr(iRow, iCol)
            Next
        Next
    Else
        outputs = arr
    End If

reverseRange = outputs
    
End Function

Public Function cellVisible(Cell) As Boolean
    Application.Volatile
    cellVisible = ((Cell.EntireColumn.hidden = False) And (Cell.EntireRow.hidden = False))
End Function

Public Function sumVisible(Inputrange As Range) As Double
    Application.Volatile
    Dim C As Range, vis As Integer
    For Each C In Inputrange
        If ((C.EntireColumn.hidden = False) And (C.EntireRow.hidden = False) And (C.Value2 <> "") And (IsNumeric(C.Value2))) Then sumVisible = sumVisible + C.Value2
    Next C
End Function

Public Function countVisible(Inputrange As Range) As Long
    Application.Volatile
    Dim C As Range, vis As Integer
    For Each C In Inputrange
        If ((C.EntireColumn.hidden = False) And (C.EntireRow.hidden = False) And (C.Value2 <> "") And IsNumeric(C.Value2)) Then countVisible = countVisible + 1
    Next C
End Function

Public Function averageVisible(Inputrange As Range) As Double
    Application.Volatile
    Dim C As Range, sum As Double, cnt As Long, vis As Integer
    sum = 0
    cnt = 0
    For Each C In Inputrange
        vis = 0
        If ((C.EntireColumn.hidden = False) And (C.EntireRow.hidden = False) And (C.Value2 <> "") And IsNumeric(C.Value2)) Then
            sum = sum + C.Value2
            cnt = cnt + 1
        End If
    Next C
    averageVisible = sum / cnt
End Function

Public Function visibleCells(Inputrange)
    Application.Volatile
    Dim arr As Variant
    Dim outputs() As Variant, op As Long
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long
    Dim hidden() As Boolean
    
    'Single cell exit
    If Not (IsArray(Inputrange)) Then
        If ((Inputrange.EntireColumn.hidden = False) And (Inputrange.EntireRow.hidden = False)) Then
            visibleCells = Inputrange.Value2
        Else
            visibleCells = ""
        End If
        Exit Function
    End If
    
    'Read visibility of columns and rows into memory
    arr = Inputrange
    nCols = UBound(arr, 2)
    nRows = UBound(arr)
   
    Dim visCol As Long
    Dim visRow As Long
    visCol = 0
    visRow = 0
    
    ReDim hidden(nCols + nRows) As Boolean
    For iCol = 1 To nCols
        hidden(iCol) = Inputrange.Cells(1, iCol).EntireColumn.hidden
        If hidden(iCol) = False Then visCol = visCol + 1
    Next
    For iRow = 1 To nRows
        hidden(nCols + iRow) = Inputrange.Cells(iRow, 1).EntireRow.hidden
        If hidden(nCols + iRow) = False Then visRow = visRow + 1
    Next
    
    'Loop through visible columns and rows, add values to array
    ReDim outputs(1 To visCol * visRow, 0)
    op = 1
    For iCol = 1 To nCols
        If hidden(iCol) = False Then
            For iRow = 1 To nRows
                If hidden(nCols + iRow) = False Then
                    'outputs(op,0) = arr(iRow, iCol): FAILURE empty cells suddenly become zero: annoying
                    'If Not (IsEmpty(arr(iRow, iCol))) Then outputs(op,0) = arr(iRow, iCol): FAILURE as well
                    If arr(iRow, iCol) = "" Then outputs(op, 0) = "" Else outputs(op, 0) = arr(iRow, iCol)
                    op = op + 1
                End If
            Next
        End If
    Next
    visibleCells = outputs
    
End Function

Public Function RangeToList(Inputrange As Variant, Optional By_columns As Boolean)
    Application.Volatile
    
    Dim arr As Variant
    Dim outputs(), op As Long
    Dim nCols As Long, nRows As Long, iCol As Long, iRow As Long
    
    'Single cell exit
    If Not (IsArray(Inputrange)) Then
        RangeToList = Inputrange
        Exit Function
    End If
    
    arr = Inputrange
    nCols = UBound(arr, 2)
    nRows = UBound(arr)
    ReDim outputs(1 To nCols * nRows, 0)
    
    op = 1
    If By_columns Then
        For iCol = 1 To nCols
            For iRow = 1 To nRows
                If arr(iRow, iCol) = "" Then outputs(op, 0) = "" Else outputs(op, 0) = arr(iRow, iCol)
                op = op + 1
            Next
        Next
    Else
        For iRow = 1 To nRows
           For iCol = 1 To nCols
                If arr(iRow, iCol) = "" Then outputs(op, 0) = "" Else outputs(op, 0) = arr(iRow, iCol)
                op = op + 1
            Next
        Next
    End If
    RangeToList = outputs
       
End Function

Public Function listtorange(Inputrange As Variant, NumColumns As Long, Optional FillRowFirst As Boolean)
    Dim arr As Variant
    Dim outputs(), op As Long
    Dim nCols As Long, nRows As Long, iRow As Long, iCol As Long
    Dim nValues As Long
    Dim horizontal As Boolean
    
    'Single cell exit
    If Not (IsArray(Inputrange)) Then
        listtorange = Inputrange
        Exit Function
    End If
    
    arr = Inputrange
    horizontal = (UBound(arr) = 1)
    nValues = UBound(arr, 2) * UBound(arr)
            
    If NumColumns > nValues Then nCols = nValues Else nCols = NumColumns
    nRows = WorksheetFunction.RoundUp(nValues / nCols, 0)
    'If there are only 9 values and numColumns has been set as 8, then 2 rows will be required
    'but with 2 rows and 9 values, only 5 columns can be filled, not 8
    'so the number of columns is recalculated as well
    If (horizontal = False) Then nCols = WorksheetFunction.RoundUp(nValues / nRows, 0)
    
    ReDim outputs(1 To nRows, 1 To nCols)
    
    op = 1
    
    If FillRowFirst Then
        For iRow = 1 To nRows
            For iCol = 1 To nCols
                If op <= nValues Then
                    If horizontal Then
                        If arr(1, op) = "" Then outputs(iRow, iCol) = "" Else outputs(iRow, iCol) = arr(1, op)
                    Else
                        If arr(op, 1) = "" Then outputs(iRow, iCol) = "" Else outputs(iRow, iCol) = arr(op, 1)
                    End If
                Else
                    outputs(iRow, iCol) = ""
                End If
                op = op + 1
            Next
        Next
    Else
        For iCol = 1 To nCols
            For iRow = 1 To nRows
                If op <= nValues Then
                    If horizontal Then
                        If arr(1, op) = "" Then outputs(iRow, iCol) = "" Else outputs(iRow, iCol) = arr(1, op)
                    Else
                        If arr(op, 1) = "" Then outputs(iRow, iCol) = "" Else outputs(iRow, iCol) = arr(op, 1)
                    End If
                Else
                    outputs(iRow, iCol) = ""
                End If
                op = op + 1
            Next
        Next
    End If
    
    listtorange = outputs
    
End Function

Public Function ExtractValues(Inputrange As Variant, Optional RowIndices As Variant, Optional ColumnIndices As Variant)
    'RowIndices input string 1|4|3|9|9 means extract rows 1,4,3,9,9
    
    Dim arr As Variant
    Dim outputs()
    Dim nCols As Long, nRows As Long, iRow As Long, iCol As Long, kRow As Long, kCol As Long, UBrows As Long, UBcols As Long
    Dim allRows As Boolean, allCols As Boolean
    Dim xtempRows 'row indices to extract
    Dim xtempCols 'col indices to extract
    Dim xRows() 'row indices to extract
    Dim xCols() 'col indices to extract
    
    allRows = IsEmpty(RowIndices)
    allCols = IsEmpty(ColumnIndices)
    If Not (allRows) Then xtempRows = Split(Mid(RowIndices, 2, Len(RowIndices) - 2), ",")
    If Not (allCols) Then xtempCols = Split(Mid(ColumnIndices, 2, Len(ColumnIndices) - 2), ",")
        
    If Not (IsArray(Inputrange)) Then
        ReDim arr(1, 1)
        arr(1, 1) = Inputrange
    Else
        arr = Inputrange
    End If
    
    If allRows And allCols Then
        ExtractValues = Inputrange
        Exit Function
    End If
    
    nRows = UBound(arr)
    nCols = UBound(arr, 2)
    
    'sanitize indices input
    If Not allRows Then
        Dim i As Long, vl As Long
        i = 0
        For iRow = 0 To UBound(xtempRows)
            vl = Val(xtempRows(iRow))
            If (vl > 0) And (vl <= nRows) Then
                ReDim Preserve xRows(i)
                xRows(i) = vl
                i = i + 1
            End If
        Next
        If (i = 0) Then
            ExtractValues = ""
            Exit Function
        End If
    End If
    If Not allCols Then
        i = 0
        For iCol = 0 To UBound(xtempCols)
            vl = Val(xtempCols(iCol))
            If (vl > 0) And (vl <= nCols) Then
                ReDim Preserve xCols(i)
                xCols(i) = vl
                i = i + 1
            End If
        Next
        If (i = 0) Then
            ExtractValues = ""
            Exit Function
        End If
    End If
    
    If allRows Then UBrows = nRows Else UBrows = UBound(xRows) + 1
    If allCols Then UBcols = nCols Else UBcols = UBound(xCols) + 1
    
    ReDim outputs(1 To UBrows, 1 To UBcols)
    
    For iRow = 1 To UBrows
        If allRows Then kRow = iRow Else kRow = xRows(iRow - 1)
        For iCol = 1 To UBcols
            If allCols Then kCol = iCol Else kCol = xCols(iCol - 1)
            If arr(kRow, kCol) = "" Then outputs(iRow, iCol) = "" Else outputs(iRow, iCol) = arr(kRow, kCol)
        Next
    Next
    
    ExtractValues = outputs
End Function

Public Function GlobeDistance(FromLatitude As Single, FromLongitude As Single, ToLatitude As Single, ToLongitude As Single, Optional InMiles As Boolean) As Single
    
    Const toRadians = 3.14159265358979 / 180
    Const R = 6371
    Dim factor As Single
    
    Dim dLat As Single, dLon As Single, lat1 As Single, lat2 As Single, a As Single
    
    lat1 = FromLatitude * toRadians
    lat2 = ToLatitude * toRadians
    dLat = lat2 - lat1
    dLon = (ToLongitude - FromLongitude) * toRadians
    a = Sin(dLat / 2) * Sin(dLat / 2) + Sin(dLon / 2) * Sin(dLon / 2) * Cos(lat1) * Cos(lat2)
    
    If InMiles Then factor = 1.60934 Else factor = 1
    
    GlobeDistance = R * 2 * WorksheetFunction.Atan2(Sqr(1 - a), Sqr(a)) / factor
    
End Function

Public Function InterpolateX(ByRef SearchValue As Range, ByRef SearchRange As Range, ByRef ValueRange As Range) As Double
    
    Dim V1 As Double, V2 As Double, S1 As Double, S2 As Double, FR As Double
    
    'if SearchValue falls outside the table, the function result is an error value
    If (SearchValue < WorksheetFunction.Min(SearchRange)) Or (SearchValue > WorksheetFunction.Max(SearchRange)) Then
        InterpolateX = (1 / 0)
        Exit Function
    End If
    
    'Determine data table points around searchvalue
    S1 = WorksheetFunction.XLookup(SearchValue, SearchRange, SearchRange, , -1)
    S2 = WorksheetFunction.XLookup(SearchValue, SearchRange, SearchRange, , 1)
    V1 = WorksheetFunction.XLookup(SearchValue, SearchRange, ValueRange, , -1)
    If S1 = S2 Then
        InterpolateX = V1
        Exit Function
    End If
    V2 = WorksheetFunction.XLookup(SearchValue, SearchRange, ValueRange, , 1)
    
    'calculate fraction
    FR = (SearchValue - S1) / (S2 - S1)
    
    'final result after interpolation
    InterpolateX = V1 + FR * (V2 - V1)
    
End Function

Public Function InterpolateXY(ByRef X As Range, ByRef Y As Range, ByRef XRange As Range, ByRef YRange As Range, ByRef ValueTable As Range) As Double
    
    'if X or Y fall outside the table, the function result is an error value
    If (X < WorksheetFunction.Min(XRange)) Or (X > WorksheetFunction.Max(XRange)) Or (Y < WorksheetFunction.Min(YRange)) Or (Y > WorksheetFunction.Max(YRange)) Then
        InterpolateXY = CVErr(xlErrNA)
        Exit Function
    End If
    
    Dim X1, X2, Y1, Y2, PX1, PX2, PY1, PY2, V1, V2, V3, V4, FX, FY, C12, C34
    
    'Determine data table points around searchvalues
    X1 = WorksheetFunction.XLookup(X, XRange, XRange, , -1)
    X2 = WorksheetFunction.XLookup(X, XRange, XRange, , 1)
    Y1 = WorksheetFunction.XLookup(Y, YRange, YRange, , -1)
    Y2 = WorksheetFunction.XLookup(Y, YRange, YRange, , 1)
    
    PX1 = WorksheetFunction.Match(X1, XRange, 0)
    PX2 = WorksheetFunction.Match(X2, XRange, 0)
    PY1 = WorksheetFunction.Match(Y1, YRange, 0)
    PY2 = WorksheetFunction.Match(Y2, YRange, 0)
    
    V1 = ValueTable(PY1, PX1)
    V2 = ValueTable(PY1, PX2)
    V3 = ValueTable(PY2, PX1)
    V4 = ValueTable(PY2, PX2)
    
    'X and Y fractions
    If (X2 = X1) Then FX = 0 Else FX = (X - X1) / (X2 - X1)
    If (Y2 = Y1) Then FY = 0 Else FY = (Y - Y1) / (Y2 - Y1)

'2 intermediate results after interpolation on X
    C12 = V1 + FX * (V2 - V1)
    C34 = V3 + FX * (V4 - V3)
    
    'final result after interpolation on Y
    InterpolateXY = C12 + FY * (C34 - C12)
    
End Function

VBA code to be put in a worksheet

Copy the VBA code below into your worksheet to enable getFolder and getFile and trigger the DatePicker by double clicking on specific cells. It is handy to take a look at the demo file how to implement. It requires named ranges 'exportpath' and 'exportfile' to be defined in your worksheet, and cells to be formatted as date for the date picker.

VBA code

Excel Various UDF (User Defined Functions)

Contents

File preview (top part only)

VBA code to be put in a module

VBA code to be put in a worksheet