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
Application.RegisterXLL
Application.RegisteredFunctions
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