User Defined Functions

If you create a large function library and want to distribute it then you should provide each function with a brief descriptive text that will be displayed in the function assistant
This text can be inserted into the object browser with the pop-up menu command Properties
The command opens a dialog box in which you can also set a reference to a help file.


Registered a function

Application.MacroOptions Macro:="functionname", Description:="hdhdhs", Category=6 

unregisters a function

Application.MacroOptions Macro:="functionname", Description:=empty, Category=empty 

SpecialCells and CurrentRegion

These methods cannot be used inside user defined functions.
Instead you will have to recreate these functions using loops
Is it possible to add help to the function arguments ?


objRange = Application.Caller 
objRange.Parent.Parent.Name

AppName = Range.Parent.Parent.Parent.Name 

Application.Caller


Can be useful in user-defined function to identify which range / worksheet etc called the function


Public Function QUADRATIC(sngValueA As Single, _ 
                          sngValueB As Single, _
                          sngValueC As Single) As Variant

Dim vReturnArray() As String
Dim sngDeterminant As Single
Dim sngreal As Single
Dim sngimaginary As Single
  
   Call Application.Volatile(True)
   ReDim vReturnArray(2)
   
   If sngValueA = 0 Then Call MsgBox("The value of A cannot be 0")
   If sngValueA = 0 Then Exit Function

   sngDeterminant = (sngValueB * sngValueB) - (4 * sngValueA * sngValueC)
   
   Select Case sngDeterminant
   
      Case Is < 0
         vReturnArray(0) = "Two Complex"
   
         sngreal = -sngValueB / (2 * sngValueA)
         sngimaginary = VBA.Sqr(-sngDeterminant) / (2 * sngValueA)
                  
         If sngreal <> 0 Then vReturnArray(1) = VBA.Round(sngreal, 2)
         If sngreal <> 0 Then vReturnArray(2) = VBA.Round(sngreal, 2)
         
         If sngreal <> 0 And sngimaginary <> 0 Then
            vReturnArray(1) = vReturnArray(1) & "+"
            vReturnArray(2) = vReturnArray(2) & "-"
         End If
         If sngimaginary <> 0 Then
            vReturnArray(1) = vReturnArray(1) & VBA.Round(sngimaginary, 2) & "i"
            vReturnArray(2) = vReturnArray(2) & -VBA.Round(sngimaginary, 2) & "i"
         End If
            
      Case Is = 0
         vReturnArray(0) = "One Real"
         vReturnArray(1) = -sngValueB / (2 * sngValueA)
         vReturnArray(1) = VBA.Round(vReturnArray(1), 3)
         
         vReturnArray(2) = "-"
   
      Case Is > 0
         vReturnArray(0) = "Two Real"
         vReturnArray(1) = (-sngValueB + VBA.Sqr(sngDeterminant)) / (2 * sngValueA)
         vReturnArray(1) = VBA.Round(vReturnArray(1), 3)
         
         vReturnArray(2) = (-sngValueB - VBA.Sqr(sngDeterminant)) / (2 * sngValueA)
         vReturnArray(2) = VBA.Round(vReturnArray(2), 3)
         
   End Select

   QUADRATIC = vReturnArray
End Function

Function DegreesCToF(ByVal sngCentigrade As Single) As Single 
   DegreesCToF = sngCentigrade * 9 / 5 + 32
End Function

Function DegreesFToC(ByVal sngFarenheit As Single) As Single 
   DegreesFToC =
End Function

Function NAMEREVERSE(strValue As String) 
strLen = Len(strValue)
strNumSpace = InStrRev(strValue, " ")
strSurname = Right(strValue, strLen - strNumSpace)
strRest = Left(strValue, strNumSpace - 1)
NAMEREVERSE = strSurname & ", " & strRest
End Function

Function CircleArea(radius as Double) As Double 
    CircleArea = (radius^2) * Application.Pi
End Function

Function ExtractElement(Txt, n, Separator) As String 
   Returns the nth element of a text string, where the elements
' are separated by a specified separator character

    Dim Txt1 As String, temperament As String
    Dim ElementCount As Integer, i As Integer
    
    Txt1 = Txt
' If space separator, remove excess spaces
    If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1)
    
' Add a separator to the end of the string
    If Right(Txt1, Len(Txt1)) <> Separator Then _
        Txt1 = Txt1 & Separator
    
' Initialize
    ElementCount = 0
    TempElement = ""
    
' Extract each element
    For i = 1 To Len(Txt1)
        If Mid(Txt1, i, 1) = Separator Then
            ElementCount = ElementCount + 1
            If ElementCount = n Then
' Found it, so exit
                ExtractElement = TempElement
                Exit Function
            Else
                TempElement = ""
            End If
        Else
            TempElement = TempElement & Mid(Txt1, i, 1)
        End If
    Next i
    ExtractElement = ""
End Function

Function STATFUNCTION(rng, op) 
    Select Case UCase(op)
        Case "SUM"
            STATFUNCTION = WorksheetFunction.Sum(rng)
        Case "AVERAGE"
            STATFUNCTION = WorksheetFunction.Average(rng)
        Case "MEDIAN"
            STATFUNCTION = WorksheetFunction.Median(rng)
        Case "MODE"
            STATFUNCTION = WorksheetFunction.Mode(rng)
        Case "COUNT"
            STATFUNCTION = WorksheetFunction.Count(rng)
        Case "MAX"
            STATFUNCTION = WorksheetFunction.Max(rng)
        Case "MIN"
            STATFUNCTION = WorksheetFunction.Min(rng)
        Case "VAR"
            STATFUNCTION = WorksheetFunction.Var(rng)
        Case "STDEV"
            STATFUNCTION = WorksheetFunction.StDev(rng)
        Case Else
            STATFUNCTION = CVErr(xlErrNA)
    End Select
End Function

Function SHEETOFFSET1(offset, Ref) 
' Returns cell contents at Ref, in sheet offset
    Application.Volatile
    SHEETOFFSET1 = Sheets(Application.Caller.Parent.Index _
      + offset).Range(Ref.Address)
End Function

Function SHEETOFFSET2(offset, Ref)
' Returns cell contents at Ref, in sheet offset
    Dim WBook As Workbook
    Dim WksCount As Integer, i As Integer
    Dim CallerSheet As String, CallerIndex As Integer
    Application.Volatile

' Create an array consisting only of Worksheets
    Set WBook = Application.Caller.Parent.Parent
    Dim Wks() As Worksheet
    WksCount = 0
    For i = 1 To WBook.Sheets.Count
        If TypeName(WBook.Sheets(i)) = "Worksheet" Then
            WksCount = WksCount + 1
            ReDim Preserve Wks(1 To WksCount)
            Set Wks(WksCount) = WBook.Sheets(i)
        End If
    Next i
    
' Determine the position of the calling sheet
    CallerSheet = Application.Caller.Parent.Name
    For i = 1 To UBound(Wks)
        If CallerSheet = Wks(i).Name Then CallerIndex = i
    Next i
    
' Get the value
    SHEETOFFSET2 = Wks(CallerIndex + _
     offset).Range(Ref.Address)
End Function

Function GetText(cell As Range) As String 
' Application.Volatile = True
   On Error Resume Next
   GetText = cell.Text
End Function

Function FontStyle(cell As Range) As String 
'Won't change value until some value on sheet changes
    Application.Volatile
    FontStyle = cell.Font.FontStyle
End Function

Function GetFormat(cell As Range) As String 
' Application.Volatile = True
   On Error Resume Next
   GetFormat = ""
   GetFormat = cell.NumberFormat
End Function

Sub FormulaBox() 
  Dim MsgBoxx As String
  Dim ix As Long
  Dim vGetFormulaI As String, xyx As String
  MsgBoxx = "First Character of " _
    & Selection.Item(ix).Address(0, 0) & " is """ _
    & Left(ActiveCell.Value, 1) & """ =CHR(" _
    & Right("0000" & Asc(ActiveCell.Value), 4) & ") or Hex=x'" _
    & Hex(Asc(ActiveCell.Value)) & "'" & Chr(10) _
    & "Last Character is """ & Right(ActiveCell.Value, 1) _
    & """ =CHR(" _
    & Right("0000" & Asc(Right(ActiveCell.Value, 1)), 4) & ") or Hex=x'" _
    & Hex(Asc(Right(ActiveCell.Value, 1))) & "'" & Chr(10) _
    & ActiveCell.Font.Name & " " & ActiveCell.Font.Size _
    & " " & ActiveCell.Font.FontStyle _
    & ", color: " & ActiveCell.Font.ColorIndex _
    & " interior: " & ActiveCell.Interior.ColorIndex _
    & Chr(10) & Chr(10)
    
  For ix = 1 To Selection.Count
'Selection.Item(ix).NoteText _ ...
      vGetFormulaI = ""
      If VarType(Selection.Item(ix)) = 8 Then
       vGetFormulaI = "'" & Selection.Item(ix).Formula
      Else
       vGetFormulaI = Selection.Item(ix).Formula
      End If
      If Selection.Item(ix).HasArray Then _
        vGetFormulaI = "{" & Selection.Item(ix).Formula & "}"
      
'include below if VarType wanted -- don't include for distribution
' & " " & VarType(Selection.Item(ix)) _ ..
      MsgBoxx = MsgBoxx _
        & Selection.Item(ix).Address(0, 0) _
        & ": " & vGetFormulaI _
        & Chr(10) & " " & Selection.Item(ix).NumberFormat & Chr(10)

  Next
  MsgBoxx = MsgBoxx & Chr(10) & "***" _
     & Chr(10) & _
     LCase(ActiveWorkbook.FullName) & " " & ActiveSheet.Name
'to verify you've seen everything
  xyx = MsgBox(MsgBoxx, , _
    "FormulaBox: Formula & Format & Text for " _
    & Selection.Count & " selected cells")
'Application.ScreenUpdating = True
End Sub

Sub FormulaSheet() 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim irow As Long, cell As Range
    Dim oSheet As Worksheet, nSheet As Worksheet
    Dim oCells As Range
    irow = 1
    Set oSheet = ActiveSheet
    Set nSheet = ActiveWorkbook.Worksheets.Add
    nSheet.Name = oSheet.Name & " content at " _
         & Format(Now(), "hhmss")
    nSheet.Cells(1, 1) = "Cell"
    nSheet.Cells(1, 2) = "Text"
    nSheet.Cells(1, 3) = "Value"
    nSheet.Cells(1, 4) = "Formula"
    nSheet.Cells(1, 5) = "NumberFormat"

    For Each cell In oSheet.UsedRange
      If Not IsEmpty(cell) Then
        irow = irow + 1
        Cells(irow, 1).Value = cell.Address(0, 0)
        Cells(irow, 2).Value = "'" & cell.Text
        Cells(irow, 3).Value = cell.Value
        Cells(irow, 4).Value = "'" & cell.Formula
        Cells(irow, 5).Value = "'" & cell.NumberFormat
      End If
    Next cell
    Columns("A:F").EntireColumn.AutoFit
    Rows("1:1").Font.Bold = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Function UseFormula(cell) 
    UseFormula = Application.Evaluate(cell.Formula)
'If "'" <> Left(cell.formula, 1) Then UseFormula = "'" & cell.formula
End Function

Function UseFormula2(cell As Range) As String 
    If Trim(cell.Value) = "" Then
       UseFormula2 = ""
       Exit Function
    ElseIf Left(cell.Value, 1) = "=" Then
       UseFormula2 = Application.Evaluate(cell.Formula)
       Exit Function
    Else
       UseFormula2 = "'#bad formula"
    End If
End Function

Function UseSameAs(cell As Range) 
      Application.Volatile
      If cell.HasFormula Then
        UseSameAs = Application.Caller.Parent.Evaluate(cell.Formula)
      Else '-- needed if constant looks like a cell address
        UseSameAs = cell.Value
      End If
End Function

Sub WhereAmI() 
    MsgBox ActiveWorkbook.FullName & Chr(10) & _
      "Microsoft Excel is using " & Application.OperatingSystem
End Sub

Sub Euro_Format() 
    Selection.NumberFormat = _
        "_(€* #,##0.00_);_(€* (#,##0.00);_(€* "" - ""???_);_(@_)"
End Sub

Function showAlign(cell As Range) As String 
   Dim ca As String
   If Trim(Replace(cell.Text, Chr(160), "")) = "" Then
        ca = "N/A"
    ElseIf cell.HorizontalAlignment = -4138 Then
           ca = "Left"
    ElseIf cell.HorizontalAlignment = -4108 Then
       ca = "Center"
    ElseIf cell.HorizontalAlignment = -4131 Then
       ca = "Left"
    ElseIf cell.HorizontalAlignment = -4152 Then
       ca = "Right"
    ElseIf IsNumeric(cell) Then
       ca = "Right"
    Else
       ca = "Left"
    End If '-4138 left, -4108 center, -4152 right, HTML default left
    showAlign = ca
End Function

Built-in SUM Equivalent

The built-in SUM function is extremely versatile.
The function must be able to handle all of the following types of arguments
a single cell reference
a literal value
a string that looks like a value
a missing argument
a logical value
an expression that uses another function
a range reference



Function MySum(ParamArray arglist() As Variant) As Variant 
' Emulates Excel's SUM function
  
' Variable declarations
  Dim arg As Variant
  Dim TempRange As Range, cell As Range
  Dim ErrCode As String
  MySum = 0

' Process each argument
  For arg = 0 To UBound(arglist)
' Skip missing arguments
    If Not IsMissing(arglist(arg)) Then
' What type of argument is it?
        Select Case TypeName(arglist(arg))
            Case "Range"
' Create temp range to handle full row or column ranges
                Set TempRange = Intersect(arglist(arg).Parent.UsedRange, arglist(arg))
                For Each cell In TempRange
                    If Application.IsErr(cell.Value) Then
                        ErrCode = CStr(cell.Value)
                        MySum = CVErr(Right(ErrCode, Len(ErrCode) - InStr(ErrCode, " ")))
                        Exit Function
                    End If
                    If cell.Value = True Or cell.Value = False Then
                        MySum = MySum + 0
                    Else
                        If IsNumeric(cell.Value) Then MySum = MySum + cell.Value
                    End If
                Next cell
            Case "Null" 'ignore it
            Case "Error" 'return the error
                MySum = arglist(arg)
                Exit Function
            Case Else
' Check for literal TRUE and compensate
                 If arglist(arg) = "True" Then MySum = MySum + 2
                 MySum = MySum + arglist(arg)
        End Select
    End If
  Next arg
End Function


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