User Defined Functions In VBA

Cell Has Data Validation

userdefinedfunctionsinvba — Tue, 27 Oct 2009 11:35:25 +0000

Public Function Cell_Has_Data_Validation(RngCell As Range) As String
On Error GoTo Cell_Has_Data_Validation_ErrorHandler

Dim LngCellValidationType As Long
‘====================================================================================================
‘Iff the cell in question is actually not a cell then return a null string and exit
‘====================================================================================================
If TypeName(RngCell) <> “Range” Then
____ Cell_Has_Data_Validation = “”
____ Exit Function
End If

‘====================================================================================================
‘Iff the cell in question is actually NOTHING then return a null string and exit
‘====================================================================================================
If RngCell Is Nothing Then
____ Cell_Has_Data_Validation = “”
____ Exit Function End If

‘====================================================================================================
‘Iff the cell in question actually consists of >1 AREA then return a null string and exit
‘====================================================================================================
If RngCell.Areas.Count <> 1 Then
____ Cell_Has_Data_Validation = “”
____ Exit Function
End If

‘====================================================================================================
‘Iff the cell in question is actually >1 CELLS then return a null string and exit
‘====================================================================================================
If RngCell.Cells.Count <> 1 Then
____ Cell_Has_Data_Validation = “”
____ Exit Function
End If

‘====================================================================================================
‘Determine iff the cell in question has validation, if it does then return “True” else an error will result and thus return “False”
‘====================================================================================================
LngCellValidationType = RngCell.Validation.Type Cell_Has_Data_Validation = “True”
Exit Function

‘====================================================================================================
‘At this juncture an error has occurred and thus return “False”
‘====================================================================================================
Cell_Has_Data_Validation_ErrorHandler:
____ Cell_Has_Data_Validation = “False”
End Function

Stringize A Range

userdefinedfunctionsinvba — Wed, 21 Oct 2009 12:20:25 +0000

Public Function Stringize_A_Range(RngInQuestion As Range, Optional StrDelimiter As Variant, Optional BolPrefixDelimit As Variant, Optional BolPostfixDelimit As Variant) As String

On Error GoTo Stringize_A_Range_ErrorHandler Dim RngArea As Range Dim RngCell As Range Dim StrResult As String

‘====================================================================================================
‘Iff the supplied range is in fact NOTHING then return a NULL STRING and exit
‘====================================================================================================
If RngInQuestion Is Nothing Then
____Stringize_A_Range = “”
____Exit Function
End If

‘====================================================================================================
‘Iff no delimiter was supplied then set the default delimiter to a comma
‘====================================================================================================
If IsMissing(StrDelimiter) Then
____StrDelimiter = “,”
End If

‘====================================================================================================
‘Iff no PREFIXING delimiter was supplied then set the default to FALSE ie do NOT prefix the result string
‘====================================================================================================
If IsMissing(BolPrefixDelimit) Then
____BolPrefixDelimit = False
End If

‘====================================================================================================
‘Iff no POSTFIXING delimiter was supplied then set the default to FALSE ie do NOT postfix the result string
‘====================================================================================================
If IsMissing(BolPostfixDelimit) Then
____BolPostfixDelimit = False
End If

‘====================================================================================================
‘Iff the result string must be prefixed then prefix same
‘====================================================================================================
If BolPrefixDelimit Then
____StrResult = StrDelimiter
End If

‘====================================================================================================
‘Cycle through each and every CELL in each and every AREA of the supplied range and assemble the result string
‘====================================================================================================
For Each RngArea In RngInQuestion.Areas
____For Each RngCell In RngArea.Cells
________StrResult = StrResult & RngCell.Value & StrDelimiter
____Next RngCell Next RngArea

‘====================================================================================================
‘Iff the result string must be postfixed then postfix same
‘====================================================================================================
If Not BolPostfixDelimit The
____StrResult = Left(StrResult, Len(StrResult) – Len(StrDelimiter))
End If

‘====================================================================================================
‘Return the result and exit the function
‘====================================================================================================
Stringize_A_Range = StrResult
Exit Function

‘====================================================================================================
‘At this juncture the result has NOT been arrived due to an error being raised now return the default error result & exit
‘====================================================================================================
Stringize_A_Range_ErrorHandler:
____Stringize_A_Range = “”
End Function

Evaluate Polynomial

userdefinedfunctionsinvba — Mon, 12 Oct 2009 21:37:28 +0000

Public Function Evaluate_Polynomial(RngExponents As Range, RngCoefficients As Range, RngX As Range) As Variant
Dim LngLoopCells As Long
Dim LngCountCells As Long
Dim DblSum As Double

‘====================================================================================================
‘Perform the necessary checks on the cells that contain the EXPONENTS
‘====================================================================================================
If TypeName(RngExponents) <> “Range” Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngExponents Is Nothing Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngExponents.Areas.Count <> 1 Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

‘====================================================================================================
‘Perform the necessary checks on the cells that contain the COEFFICIENTS
‘====================================================================================================
If TypeName(RngCoefficients) <> “Range” Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngCoefficients Is Nothing Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngCoefficients.Areas.Count <> 1 Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

‘====================================================================================================
‘Make sure that the number of COEFFICIENTS matches the number of EXPONENTS
‘====================================================================================================
If RngExponents.Cells.Count <> RngCoefficients.Cells.Count Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If TypeName(RngX) <> “Range” Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngX Is Nothing Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

‘====================================================================================================
‘Perform the necessary checks on the X-value
‘====================================================================================================
If RngX.Areas.Count <> 1 Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If RngX.Cells.Count <> 1 Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

If Not IsNumeric(RngX) Then
——–Polynomial = “UNDEFINED”
——–Exit Function
End If

‘====================================================================================================
‘Determine the number of terms in the polynomial
‘====================================================================================================
LngCountCells = RngExponents.Cells.Count

‘====================================================================================================
‘Loop through the coefficient and exponent pairs and multiply accordingly summing up on each iteration
‘====================================================================================================
For LngLoopCells = 1 To LngCountCells
——–DblSum = DblSum + RngCoefficients.Cells(LngLoopCells).Value * (RngX.Value ^ RngExponents.Cells(LngLoopCells).Value)
Next LngLoopCells

‘====================================================================================================
‘Return the result
‘====================================================================================================
Evaluate_Polynomial = DblSum

End Function

Match UDF

userdefinedfunctionsinvba — Sat, 03 Oct 2009 13:03:32 +0000

Public Function Match_UDF(RngValue2Find As Range, Rng2Search As Range, Optional BolCaseSensitive As Variant) As Range
On Error GoTo Match_UDF_ErrorHandler
Dim RngArea As Range
Dim RngCell As Range
Dim VarValue2Find As Variant

‘====================================================================================================
‘Return NOTHING iff the RngValue2Find is itself NOTHING and EXIT
‘====================================================================================================
If RngValue2Find Is Nothing Then
Set Match_UDF = Nothing
Exit Function
End If

‘====================================================================================================
‘Return NOTHING iff the RngValue2Find has more than 1 AREA and EXIT
‘====================================================================================================
If RngValue2Find.Areas.Count <> 1 Then
Set Match_UDF = Nothing
Exit Function
End If

‘====================================================================================================
‘Return NOTHING iff the RngValue2Find has more than 1 CELL and EXIT
‘====================================================================================================
If RngValue2Find.Cells.Count <> 1 Then
Set Match_UDF = Nothing
Exit Function
End If

‘====================================================================================================
‘Return NOTHING iff the Rng2Search is itself NOTHING and EXIT
‘====================================================================================================
If Rng2Search Is Nothing Then
Set Match_UDF = Nothing
Exit Function
End If

‘====================================================================================================
‘Set the default to CASE INSENSITIVE iff needs be
‘====================================================================================================
If IsMissing(BolCaseSensitive) Then
BolCaseSensitive = False
End If

‘====================================================================================================
‘Make a note of the value to be found
‘====================================================================================================
VarValue2Find = RngValue2Find.Value

‘====================================================================================================
‘If CASE INSENSITIVITY is the setting then uppercase the value to find
‘====================================================================================================
If Not BolCaseSensitive Then
RngValue2Find = UCase(RngValue2Find)
End If

‘====================================================================================================
‘Cycle through each of the AREAS in the range to seach and ALL of the cells therein
‘====================================================================================================
For Each RngArea In Rng2Search.Areas
        For Each RngCell In RngArea.Cells
                ‘====================================================================================================
                ‘iff the cell to be found is actually found then return it’s single cell range location and exit
                ‘====================================================================================================
                If BolCaseSensitive Then

                        If RngCell.Value = RngValue2Find Then
                                Set Match_UDF = RngCell
                                Exit Function
                       End If
                ‘====================================================================================================
                ’iff the [UCASE] cell to be found is actually found [case insensitive match] return it’s single cell range location & exit
                ‘====================================================================================================
                Else
                        If UCase(RngCell.Value) = RngValue2Find Then
                                Set Match_UDF = RngCell
                                Exit Function
                        End If
               End If
       Next RngCell
Next RngArea

Exit Function

‘====================================================================================================
‘At this point an error of some sort has occurred and thus return NOTHING
‘====================================================================================================
Match_UDF_ErrorHandler:
Set Match_UDF = Nothing
End Function

File Date And Time

userdefinedfunctionsinvba — Fri, 11 Sep 2009 09:58:18 +0000

Public Function File_Date_And_Time(StrFileSpec As String) As String

On Error GoTo File_Date_And_Time _ErrorHandler
‘====================================================================================================
‘This function returns the DATE and TIME (of CREATION) of the supplied filename
‘====================================================================================================
________File_Date_And_Time = CStr(FileDateTime(StrFileSpec))
Exit Function

‘====================================================================================================
‘At this juncture an error has returned therefore return a NULL string
‘====================================================================================================
File_Date_And_Time _ErrorHandler:
________File_Date_And_Time = “”
End Function

Count Shapes In ActiveWorksheet

userdefinedfunctionsinvba — Wed, 09 Sep 2009 10:12:10 +0000

‘====================================================================================================
‘This function returns the number of SHAPES in the ActiveSheet ‘====================================================================================================
Public Function Count_Shapes_In_ActiveWorksheet() As Long
Dim SHP As Shape

For Each SHP In ActiveSheet.Shapes
________Count_Shapes_In_ActiveWorksheet = Count_Shapes_In_ActiveWorksheet + 1
Next SHP

End Function

Remove Bottom Row From Supplied Range

userdefinedfunctionsinvba — Tue, 08 Sep 2009 14:04:23 +0000

‘====================================================================================================
‘This function range removes the BOTTOM-most row from said range and returns same as the result
‘====================================================================================================
Public Function Remove_Bottom_Row_From_Supplied_Range(RngInQuestion As Range) As Range
On Error GoTo Remove_Bottom_Row_From_Supplied_Range_ErrorHandler

‘====================================================================================================
‘Iff the supplied range is NOTHING then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion Is Nothing Then
________Set Remove_Bottom_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has more than 1 AREA then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Areas.Count <> 1 Then
________Set Remove_Bottom_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has 1 ROW then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Rows.Count <= 1 Then
________Set Remove_Bottom_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Reduce the size of the supplied range (ignore the BOTTOMmost column) return the result and EXIT
‘====================================================================================================
Set Remove_Bottom_Row_From_Supplied_Range = RngInQuestion.Resize(RngInQuestion.Rows.Count – 1,
RngInQuestion.Columns.Count)
Exit Function

‘====================================================================================================
‘At this juncture an error of some sort has been arrived at therefore return NOTHING on EXITING
‘====================================================================================================
Remove_Bottom_Row_From_Supplied_Range_ErrorHandler:
________Set Remove_Bottom_Row_From_Supplied_Range = Nothing
End Function

Remove Top Row From Supplied Range

userdefinedfunctionsinvba — Tue, 08 Sep 2009 14:01:24 +0000

‘====================================================================================================
‘This function when supplied with a range removes the TOPmost row from said range and returns same as the result
‘====================================================================================================
Public Function Remove_Top_Row_From_Supplied_Range(RngInQuestion As Range) As Range
On Error GoTo Remove_Top_Row_From_Supplied_Range_ErrorHandler

‘====================================================================================================
‘Iff the supplied range is NOTHING then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion Is Nothing Then
________Set Remove_Top_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has more than 1 AREA then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Areas.Count <> 1 Then
________Set Remove_Top_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has 1 ROW then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Rows.Count <= 1 Then
________Set Remove_Top_Row_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Reduce the size of the supplied range (ignore the TOPMOST column) return the result and EXIT
‘====================================================================================================
Set Remove_Top_Row_From_Supplied_Range = RngInQuestion.Resize(RngInQuestion.Rows.Count – 1, RngInQuestion.Columns.Count).Offset(1, 0)
Exit Function

‘====================================================================================================
‘At this juncture an error of some sort has been arrived at therefore return NOTHING on EXITING
‘====================================================================================================
Remove_Top_Row_From_Supplied_Range_ErrorHandler:
________Set Remove_Top_Row_From_Supplied_Range = Nothing
End Function

Remove Left Column From Supplied Range

userdefinedfunctionsinvba — Tue, 08 Sep 2009 13:59:16 +0000

‘====================================================================================================
‘This function when supplied with a range removes the LEFTmost column from said range and returns same as the result
‘====================================================================================================
Public Function Remove_Left_Column_From_Supplied_Range(RngInQuestion As Range) As Range
On Error GoTo Remove_Left_Column_From_Supplied_Range_ErrorHandler
‘====================================================================================================
‘Iff the supplied range is NOTHING then return NOTHING and EXIT
‘====================================================================================================

If RngInQuestion Is Nothing Then
________Set Remove_Left_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has more than 1 AREA then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Areas.Count <> 1 Then
________Set Remove_Left_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has 1 COLUMN then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Columns.Count <= 1 Then
________Set Remove_Left_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Reduce the size of the supplied range (ignore the LEFTMOST column) return the result and EXIT
‘====================================================================================================
Set Remove_Left_Column_From_Supplied_Range = RngInQuestion.Resize(RngInQuestion.Rows.Count, RngInQuestion.Columns.Count – 1).Offset(0, 1)
Exit Function

‘====================================================================================================
‘At this juncture an error of some sort has been arrived at therefore return NOTHING on EXITING
‘====================================================================================================
Remove_Left_Column_From_Supplied_Range_ErrorHandler:
________Set Remove_Left_Column_From_Supplied_Range = Nothing
End Function

Remove Right Column From Supplied Range

userdefinedfunctionsinvba — Tue, 08 Sep 2009 13:58:43 +0000

‘====================================================================================================
‘This function when supplied with a range removes the RIGHTmost column from said range and returns same as the result
‘====================================================================================================
Public Function Remove_Right_Column_From_Supplied_Range(RngInQuestion As Range) As Range
On Error GoTo Remove_Right_Column_From_Supplied_Range_ErrorHandler

‘====================================================================================================
‘Iff the supplied range is NOTHING then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion Is Nothing Then
________Set Remove_Right_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has more than 1 AREA then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Areas.Count <> 1 Then
________Set Remove_Right_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Iff the supplied range has 1 COLUMN then return NOTHING and EXIT
‘====================================================================================================
If RngInQuestion.Columns.Count <= 1 Then
________Set Remove_Right_Column_From_Supplied_Range = Nothing
________Exit Function
End If

‘====================================================================================================
‘Reduce the size of the supplied range (ignore the RIGHTMOST column), return the result and EXIT
‘====================================================================================================
Set Remove_Right_Column_From_Supplied_Range = RngInQuestion.Resize(RngInQuestion.Rows.Count, RngInQuestion.Columns.Count – 1)

Exit Function
‘====================================================================================================
‘At this juncture an error of some sort has been arrived at therefore return NOTHING on EXITING
‘====================================================================================================
Remove_Right_Column_From_Supplied_Range_ErrorHandler:
________Set Remove_Right_Column_From_Supplied_Range = Nothing
End Function