14. Sample User-Defined Functions
Excel provides many built-in functions. However, sometimes you need a complex custom function that Excel doesn’t offer, such as a function that sums a range of cells based on their interior color.
So, what do you do? You could go down your list and copy the colored cells to another section. Or perhaps you have a calculator next to you as you work your way down your list—but be careful not to enter the same number twice! Both methods are time-consuming and prone to accidents. What to do?
You could write a procedure to solve this problem—after all, that’s what this book is about. However, you have another option: user-defined functions (UDFs).
Creating User-Defined Functions
You can create your own functions in VBA and then use them just like you use Excel’s built-in functions, such as SUM. After the custom function is created, a user needs to know only the function name and its arguments.
You can enter UDFs only into standard modules. Sheet and ThisWorkbook modules are a special type of module. If you enter a UDF in either of those modules, Excel does not recognize that you are creating a UDF.
Case Study: Custom Functions: Example and Explanation
Add(Number1,Number2)
Function Add(Number1 As Integer, Number2 As Integer) As Integer
Add = Number1 + Number2
End Function
The function name is ADD.
Arguments are placed in parentheses after the name of the function. This example has two arguments: Number1 and Number2.
As Integer defines the variable type of the result as a whole number.
ADD = Number1 + Number2 is the result of the function that is returned.
1. Type numbers into cells A1 and A2.
2. Select cell A3.
3. Press Shift+F3 to open the Insert Function dialog box, or choose Formulas, Insert Function.
4. In the Insert Function dialog, select the User Defined category (see Figure 14.1).
5. Select the Add function.
6. In the first argument box, select cell A1 (see Figure 14.2).
7. In the second argument box, select cell A2.
8. Click OK.
Figure 14.1 You can find your UDFs under the User Defined category of the Insert Function dialog box.
You can easily share custom functions because users are not required to know how the function works. See the section “Sharing UDFs,” later in this chapter, for more information.
Most of the functions used on sheets can also be used in VBA and vice versa. However, in VBA you call the UDF (ADD) from a procedure (Addition), like this:
Sub Addition ()
Dim Total as Integer
Total = Add (1,10) 'we use a user-defined function Add
MsgBox "The answer is: " & Total
End Sub
Personal.xlsb—Store a UDF in Personal.xlsb if it is just for your use and won’t be used in a workbook opened on another computer.
Workbook—Store a UDF in the workbook in which it is being used if it needs to be distributed to many people.
Add-in—Distribute a UDF via an add-in if the workbook is to be shared among a select group of people. See Chapter 26, “Creating Add-ins,” for information on how to create an add-in.
Template—Store a UDF in a template if it needs to be used to create several workbooks and the workbooks are distributed to many people.
Useful Custom Excel Functions
The sections that follow include a sampling of functions that can be useful in the everyday Excel world.
Note
This chapter shows functions donated by several Excel programmers. These are functions that they have found useful and that they hope will also be of help to you.
Different programmers have different programming styles. We did not rewrite the submissions. As you review the lines of code, you might notice different ways of doing the same task, such as referring to ranges.
Setting the Current Workbook’s Name in a Cell
The following function sets the name of the active workbook in a cell, as shown in Figure 14.3:
MyName()
No arguments are used with this function:
Function MyName() As String
MyName = ThisWorkbook.Name
End Function
Setting the Current Workbook’s Name and File Path in a Cell
A variation of the preceding function, the following function sets the file path and name of the active workbook in a cell, as shown previously in Figure 14.3:
MyFullName()
No arguments are used with this function:
Function MyFullName() As String
MyFullName = ThisWorkbook.FullName
End Function
Checking Whether a Workbook Is Open
There might be times when you need to check whether a workbook is open. The following function returns True if a workbook is open and False if it is not:
BookOpen(Bk)
The argument is Bk, which is the name of the workbook being checked:
Function BookOpen(Bk As String) As Boolean
Dim T As Excel.Workbook
Err.Clear 'clears any errors
On Error Resume Next 'if the code runs into an error, it skips it and 'continues
Set T = Application.Workbooks(Bk)
BookOpen = Not T Is Nothing
'If the workbook is open, then T will hold the workbook object and 'therefore will NOT be Nothing
Err.Clear
On Error GoTo 0
End Function
Here is an example of using the function:
Sub OpenAWorkbook()
Dim IsOpen As Boolean
Dim BookName As String
BookName = "ProjectFilesChapter14.xlsm"
IsOpen = BookOpen(BookName) 'calling our function - don't forget the 'parameter
If IsOpen Then
MsgBox BookName & " is already open!"
Else
Workbooks.Open (BookName)
End If
End Sub
Checking Whether a Sheet in an Open Workbook Exists
This function requires that the workbook(s) it checks be open. It returns True if the sheet is found and False if it is not:
SheetExists(SName, WBName)
SName—The name of the sheet being searched
WBName—(Optional) The name of the workbook that contains the sheet
Here is the function. If the workbook argument is not provided, it uses the active workbook:
Function SheetExists(SName As String, Optional WB As Workbook) As Boolean
Dim WS As Worksheet
' Use active workbook by default
If WB Is Nothing Then
Set WB = ActiveWorkbook
End If
On Error Resume Next
SheetExists = CBool(Not WB.Sheets(SName) Is Nothing)
On Error GoTo 0
End Function
Here is an example of using this function:
Note
CBool is a function that converts the expression between the parentheses to a Boolean value.
Sub CheckForSheet()
Dim ShtExists As Boolean
ShtExists = SheetExists("Sheet9")
'notice that only one parameter was passed; the workbook name is optional
If ShtExists Then
MsgBox "The worksheet exists!"
Else
MsgBox "The worksheet does NOT exist!"
End If
End Sub
Counting the Number of Workbooks in a Directory
This function searches the current directory, and its subfolders if you want, counting all Excel macro workbook files (.xlsm), including hidden files, or just the ones starting with a string of letters:
NumFilesInCurDir (LikeText, Subfolders)
These are the arguments:
LikeText—(Optional) A string value to search for; must include an asterisk (*), such as Mr*
Subfolders—(Optional) True to search subfolders, False (default) not to
FileSystemObject requires the Microsoft Scripting Runtime reference library. To enable this setting, go to Tools, References and check Microsoft Scripting Runtime.
This function is a recursive function, which means it calls itself until a specific condition is met—in this case, until all subfolders are processed. Here is the function:
Function NumFilesInCurDir(Optional strInclude As String = "", _
Optional blnSubDirs As Boolean = False)
Dim fso As FileSystemObject
Dim fld As Folder
Dim fil As File
Dim subfld As Folder
Dim intFileCount As Integer
Dim strExtension As String
strExtension = "XLSM"
Set fso = New FileSystemObject
Set fld = fso.GetFolder(ThisWorkbook.Path)
For Each fil In fld.Files
If UCase(fil.Name) Like "*" & UCase(strInclude) & "*." & _
UCase(strExtension) Then
intFileCount = intFileCount + 1
End If
Next fil
If blnSubDirs Then
For Each subfld In fld.Subfolders
intFileCount = intFileCount + NumFilesInCurDir(strInclude, True)
Next subfld
End If
NumFilesInCurDir = intFileCount
Set fso = Nothing
End Function
Here is an example of using this function:
Sub CountMyWkbks()
Dim MyFiles As Integer
MyFiles = NumFilesInCurDir("MrE*", True)
MsgBox MyFiles & " file(s) found"
End Sub
Retrieving the User ID
Ever need to keep a record of who saves changes to a workbook? With the USERID function, you can retrieve the name of the user who is logged in to a computer. Combine it with the function discussed in the “Retrieving Permanent Date and Time” section, later in this chapter, and you have a nice log file. You can also use the USERID function to set up user rights to a workbook.
WinUserName ()
No arguments are used with this function.
The USERID function is an advanced function that uses the application programming interface (API), which is reviewed in Chapter 23, “The Windows Application Programming Interface (API).” The code is specific to 32-bit Excel. If you are running 64-bit Excel, refer to Chapter 23 for changes to make it work.
This first section (Private declarations) must be at the top of the module:
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" _
(ByVal lpName As String, ByVal lpUserName As String, _
lpnLength As Long) As Long
Private Const NO_ERROR = 0
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
You can place the following section of code anywhere in the module, as long as it is below the preceding section:
Function WinUsername() As String
'variables
Dim strBuf As String, lngUser As Long, strUn As String
'clear buffer for user name from api func
strBuf = Space$(255)
'use api func WNetGetUser to assign user value to lngUser
'will have lots of blank space
lngUser = WNetGetUser("", strBuf, 255)
'if no error from function call
If lngUser = NO_ERROR Then
'clear out blank space in strBuf and assign val to function
strUn = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
WinUsername = strUn
Else
'error, give up
WinUsername = "Error :" & lngUser
End If
End Function
Here’s an example of using this function:
Sub CheckUserRights()
Dim UserName As String
UserName = WinUsername
Select Case UserName
Case "Administrator"
MsgBox "Full Rights"
Case "Guest"
MsgBox "You cannot make changes"
Case Else
MsgBox "Limited Rights"
End Select
End Sub
Retrieving Date and Time of Last Save
This function retrieves the saved date and time of any workbook, including the current one:
LastSaved(FullPath)
Note
The cell must be formatted for date and time to display the date/time correctly.
The argument is FullPath, a string showing the full path and filename of the file in question:
Function LastSaved(FullPath As String) As Date
LastSaved = FileDateTime(FullPath)
End Function
Retrieving Permanent Date and Time
Because of the volatility of the NOW function, it isn’t very useful for stamping a worksheet with the creation or editing date. Every time the workbook is opened or recalculated, the result of the NOW function is updated. The following UDF uses the NOW function. However, because you need to reenter the cell to update the function, it is much less volatile (see Figure 14.4):
DateTime()
Figure 14.4 Even after forcing a recalculation, the DateTime() cell shows the time when it was originally placed in the cell, whereas NOW() shows the current system time.
No arguments are used with this function:
DateTime()
Note
The cell must be formatted properly to display the date/time.
Here’s is the function:
Function DateTime()
DateTime = Now
End Function
Validating an Email Address
If you manage an email subscription list, you might receive invalid email addresses, such as addresses with a space before the “at” symbol (@). The ISEMAILVALID function can check addresses and confirm that they are proper email addresses (see Figure 14.5):
IsEmailValid (strEmail)
Note
This function cannot verify that an email address is an existing one. It only checks the syntax to verify that the address might be legitimate.
The function’s only argument is strEmail, an email address:
Function IsEmailValid(strEmail As String) As Boolean
Dim strArray As Variant
Dim strItem As Variant
Dim i As Long
Dim c As String
Dim blnIsItValid As Boolean
blnIsItValid = True
'count the @ in the string
i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
'if there is more than one @, invalid email
If i <> 1 Then IsEmailValid = False: Exit Function
ReDim strArray(1 To 2)
'the following two lines place the text to the left and right
'of the @ in their own variables
strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - _
Len(strArray(1))), "@", "")
For Each strItem In strArray
'verify there is something in the variable.
'If there isn't, then part of the email is missing
If Len(strItem) <= 0 Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
'verify only valid characters in the email
For i = 1 To Len(strItem)
'lowercases all letters for easier checking
c = LCase(Mid(strItem, i, 1))
If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 _
And Not IsNumeric(c) Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
Next i
'verify that the first character of the left and right aren't periods
If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
Next strItem
'verify there is a period in the right half of the address
If InStr(strArray(2), ".") <= 0 Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
i = Len(strArray(2)) - InStrRev(strArray(2), ".") 'locate the period
'verify that the number of letters corresponds to a valid domain 'extension
If i <> 2 And i <> 3 And i <> 4 Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
'verify that there aren't two periods together in the email
If InStr(strEmail, "..") > 0 Then
blnIsItValid = False
IsEmailValid = blnIsItValid
Exit Function
End If
IsEmailValid = blnIsItValid
End Function
Summing Cells Based on Interior Color
Let’s say you have created a list of how much each of your clients owes. From this list, you want to sum just the cells to which you have applied a cell fill to indicate clients who are 30 days past due. This function sums cells based on their fill color.
SumColor(CellColor, SumRange)
Note
Cells colored by conditional formatting will not work; the cells must have an interior color.
These are the arguments:
CellColor—The address of a cell with the target color
SumRange—The range of cells to be searched
Function SumByColor(CellColor As Range, SumRange As Range)
Dim myCell As Range
Dim iCol As Integer
Dim myTotal
iCol = CellColor.Interior.ColorIndex 'get the target color
For Each myCell In SumRange 'look at each cell in the designated range
'if the cell color matches the target color
If myCell.Interior.ColorIndex = iCol Then
'add the value in the cell to the total
myTotal = WorksheetFunction.Sum(myCell) + myTotal
End If
Next myCell
SumByColor = myTotal
End Function
Figure 14.6 shows a sample worksheet using this function.
Counting Unique Values
How many times have you had a long list of values and needed to know how many were unique values? This function goes through a range and provides that information, as shown in Figure 14.7:
NumUniqueValues(Rng)
The argument is Rng, the range to search unique values.
Here is the function’s code:
Function NumUniqueValues(Rng As Range) As Long
Dim myCell As Range
Dim UniqueVals As New Collection
Application.Volatile 'forces the function to recalculate when the range
'changes
On Error Resume Next
'the following places each value from the range into a collection
'because a collection, with a key parameter, can contain only unique
'values,there will be no duplicates. The error statements force the
'program to continue when the error messages appear for duplicate
'items in the collection
For Each myCell In Rng
UniqueVals.Add myCell.Value, CStr(myCell.Value)
Next myCell
On Error GoTo 0
'returns the number of items in the collection
NumUniqueValues = UniqueVals.Count
End Function
Removing Duplicates from a Range
No doubt you have also had a list of items and needed to list only the unique values. The following function goes through a range and stores only the unique values:
UniqueValues (OrigArray)
The argument is OrigArray, an array from which the duplicates will be removed.
This first section (Const declarations) must be at the top of the module:
Const ERR_BAD_PARAMETER = "Array parameter required"
Const ERR_BAD_TYPE = "Invalid Type"
Const ERR_BP_NUMBER = 20000
Const ERR_BT_NUMBER = 20001
You can place the following section of code anywhere in the module, as long as it is below the code just shown:
Public Function UniqueValues(ByVal OrigArray As Variant) As Variant
Dim vAns() As Variant
Dim lStartPoint As Long
Dim lEndPoint As Long
Dim lCtr As Long, lCount As Long
Dim iCtr As Integer
Dim col As New Collection
Dim sIndex As String
Dim vTest As Variant, vItem As Variant
Dim iBadVarTypes(4) As Integer
'Function does not work if array element is one of the
'following types
iBadVarTypes(0) = vbObject
iBadVarTypes(1) = vbError
iBadVarTypes(2) = vbDataObject
iBadVarTypes(3) = vbUserDefinedType
iBadVarTypes(4) = vbArray
'Check to see whether the parameter is an array
If Not IsArray(OrigArray) Then
Err.Raise ERR_BP_NUMBER, , ERR_BAD_PARAMETER
Exit Function
End If
lStartPoint = LBound(OrigArray)
lEndPoint = UBound(OrigArray)
For lCtr = lStartPoint To lEndPoint
vItem = OrigArray(lCtr)
'First check to see whether variable type is acceptable
For iCtr = 0 To UBound(iBadVarTypes)
If VarType(vItem) = iBadVarTypes(iCtr) Or _
VarType(vItem) = iBadVarTypes(iCtr) + vbVariant Then
Err.Raise ERR_BT_NUMBER, , ERR_BAD_TYPE
Exit Function
End If
Next iCtr
'Add element to a collection, using it as the index
'if an error occurs, the element already exists
sIndex = CStr(vItem)
'first element, add automatically
If lCtr = lStartPoint Then
col.Add vItem, sIndex
ReDim vAns(lStartPoint To lStartPoint) As Variant
vAns(lStartPoint) = vItem
Else
On Error Resume Next
col.Add vItem, sIndex
If Err.Number = 0 Then
lCount = UBound(vAns) + 1
ReDim Preserve vAns(lStartPoint To lCount)
vAns(lCount) = vItem
End If
End If
Err.Clear
Next lCtr
UniqueValues = vAns
End Function
Here is an example of using this function:
Function nodupsArray(rng As Range) As Variant
Dim arr1() As Variant
If rng.Columns.Count > 1 Then Exit Function
arr1 = Application.Transpose(rng)
arr1 = UniqueValues(arr1)
nodupsArray = Application.Transpose(arr1)
End Function
Finding the First Nonzero-Length Cell in a Range
Suppose you have imported a large list of data with many empty cells. Here is a function that evaluates a range of cells and returns the value of the first nonzero-length cell:
FirstNonZeroLength(Rng)
The argument is Rng, the range to search.
Here’s the function:
Function FirstNonZeroLength(Rng As Range)
Dim myCell As Range
FirstNonZeroLength = 0#
For Each myCell In Rng
If Not IsNull(myCell) And myCell <> "" Then
FirstNonZeroLength = myCell.Value
Exit Function
End If
Next myCell
FirstNonZeroLength = myCell.Value
End Function
Figure 14.8 shows the function on a sample worksheet.
Substituting Multiple Characters
Excel has a substitute function, but it is a value-for-value substitution. What if you have several characters you need to substitute? Figure 14.9 shows several examples of how this function works.
MSubstitute(trStr, frStr, toStr)
These are the arguments:
trStr—The string to be searched
frStr—The text being searched for
toStr—The replacement text
Here’s the function’s code:
Function MSubsitute(ByVal trStr As Variant, frStr As String, _
toStr As String) As Variant
Dim iCol As Integer
Dim j As Integer
Dim Ar As Variant
Dim vfr() As String
Dim vto() As String
ReDim vfr(1 To Len(frStr))
ReDim vto(1 To Len(frStr))
'place the strings into an array
For j = 1 To Len(frStr)
vfr(j) = Mid(frStr, j, 1)
If Mid(toStr, j, 1) <> "" Then
vto(j) = Mid(toStr, j, 1)
Else
vto(j) = ""
End If
Next j
'compare each character and substitute if needed
If IsArray(trStr) Then
Ar = trStr
For iRow = LBound(Ar, 1) To UBound(Ar, 1)
For iCol = LBound(Ar, 2) To UBound(Ar, 2)
For j = 1 To Len(frStr)
Ar(iRow, iCol) = Application.Substitute(Ar(iRow, iCol), _
vfr(j), vto(j))
Next j
Next iCol
Next iRow
Else
Ar = trStr
For j = 1 To Len(frStr)
Ar = Application.Substitute(Ar, vfr(j), vto(j))
Next j
End If
MSUBSTITUTE = Ar
End Function
Note
The toStr argument is assumed to be the same length as frStr. If it isn’t, the remaining characters are considered null (""). The function is case sensitive. To replace all instances of a, use a and A. You cannot replace one character with two characters. For example, this:
=MSUBSTITUTE("This is a test","i","$@")
results in this:
"Th$s $s a test"
Retrieving Numbers from Mixed Text
This function extracts and returns numbers from text that is a mixture of numbers and letters:
RetrieveNumbers (myString)
The argument is myString, the text containing the numbers to be extracted.
Here’s the function’s code:
Function RetrieveNumbers(myString As String)
Dim i As Integer, j As Integer
Dim OnlyNums As String
'starting at the END of the string and moving backwards (Step -1)
For i = Len(myString) To 1 Step -1
'IsNumeric is a VBA function that returns True if a variable is a number
'When a number is found, it is added to the OnlyNums string
If IsNumeric(Mid(myString, i, 1)) Then
j = j + 1
OnlyNums = Mid(myString, i, 1) & OnlyNums
End If
If j = 1 Then OnlyNums = CInt(Mid(OnlyNums, 1, 1))
Next i
RetrieveNumbers = CLng(OnlyNums)
End Function
Converting Week Number into Date
Have you ever received a spreadsheet report in which all the headers showed the week number? This can be confusing because you probably wouldn’t know what Week 15 actually is. You would have to get out your calendar and count the weeks. This problem is exacerbated if you need to count weeks in a previous year. In this case, you need a nice little function that converts Week ## Year into the date of a particular day in a given week, as shown in Figure 14.10:
Weekday(Str)
Note
The result must be formatted as a date.
The argument is Str, the week to be converted, in "Week ## YYYY" format.
Here’s the function’s code:
Function ConvertWeekDay(Str As String) As Date
Dim Week As Long
Dim FirstMon As Date
Dim TStr As String
FirstMon = DateSerial(Right(Str, 4), 1, 1)
FirstMon = FirstMon - FirstMon Mod 7 + 2
TStr = Right(Str, Len(Str) - 5)
Week = Left(TStr, InStr(1, TStr, " ", 1)) + 0
ConvertWeekDay = FirstMon + (Week - 1) * 7
End Function
Extracting a Single Element from a Delimited String
Say that you need to paste a column of delimited data. You could use Excel’s Text to Columns feature, but you need only an element or two from each cell. Text to Columns parses the entire thing. In this case, you need a function that lets you specify the number of the element in a string that you need, as shown in Figure 14.11:
StringElement(str,chr,ind)
These are the arguments:
str—The string to be parsed
chr—The delimiter
ind—The position of the element to be returned
Here’s the function’s code:
Function StringElement(str As String, chr As String, ind As Integer)
Dim arr_str As Variant
arr_str = Split(str, chr) 'Not compatible with XL97
StringElement = arr_str(ind - 1)
End Function
Sorting and Concatenating
The following function enables you to take a column of data, sort it by numbers and then by letters, and concatenate it using a comma (,) as the delimiter (see Figure 14.12). Note that since the numbers are treated as strings, they are sorted lexicographically (all numbers that start with 1, then numbers that start with 2, etc.). For example, if sorting 1,2,10, you would actually get 1,10,2 since 10 starts with a 1, which comes before 2:
SortConcat(Rng)
The argument is Rng, the range of data to be sorted and concatenated. SortConcat calls another procedure, BubbleSort, that must be included.
Here’s the main function:
Function SortConcat(Rng As Range) As Variant
Dim MySum As String, arr1() As String
Dim j As Integer, i As Integer
Dim cl As Range
Dim concat As Variant
On Error GoTo FuncFail:
'initialize output
SortConcat = 0#
'avoid user issues
If Rng.Count = 0 Then Exit Function
'get range into variant variable holding array
ReDim arr1(1 To Rng.Count)
'fill array
i = 1
For Each cl In Rng
arr1(i) = cl.Value
i = i + 1
Next
'sort array elements
Call BubbleSort(arr1)
'create string from array elements
For j = UBound(arr1) To 1 Step -1
If Not IsEmpty(arr1(j)) Then
MySum = arr1(j) & ", " & MySum
End If
Next j
'assign value to function
SortConcat = Left(MySum, Len(MySum) - 1)
'exit point
concat_exit:
Exit Function
'display error in cell
FuncFail:
SortConcat = Err.Number & " - " & Err.Description
Resume concat_exit
End Function
The following function is the ever-popular BubbleSort. Many developers use this program to do a simple sort of data.
Sub BubbleSort(List() As String)
' Sorts the List array in ascending order
Dim First As Integer, Last As Integer
Dim i As Integer, j As Integer
Dim Temp
First = LBound(List)
Last = UBound(List)
For i = First To Last - 1
For j = i + 1 To Last
If List(i) > List(j) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End Sub
Sorting Numeric and Alpha Characters
This function takes a mixed range of numeric and alpha characters and sorts them—first numerically and then alphabetically:
sorter(Rng)
The result is placed in an array that can be displayed on a worksheet by using an array formula, as shown in Figure 14.13.
The argument is Rng, the range to be sorted.
The function uses the following two procedures to sort the data in the range:
Public Sub QuickSort(ByRef vntArr As Variant, _
Optional ByVal lngLeft As Long = -2, _
Optional ByVal lngRight As Long = -2)
Dim i, j, lngMid As Long
Dim vntTestVal As Variant
If lngLeft = -2 Then lngLeft = LBound(vntArr)
If lngRight = -2 Then lngRight = UBound(vntArr)
If lngLeft < lngRight Then
lngMid = (lngLeft + lngRight) 2
vntTestVal = vntArr(lngMid)
i = lngLeft
j = lngRight
Do
Do While vntArr(i) < vntTestVal
i = i + 1
Loop
Do While vntArr(j) > vntTestVal
j = j - 1
Loop
If i <= j Then
Call SwapElements(vntArr, i, j)
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= lngMid Then
Call QuickSort(vntArr, lngLeft, j)
Call QuickSort(vntArr, i, lngRight)
Else
Call QuickSort(vntArr, i, lngRight)
Call QuickSort(vntArr, lngLeft, j)
End If
End If
End Sub
Private Sub SwapElements(ByRef vntItems As Variant, _
ByVal lngItem1 As Long, _
ByVal lngItem2 As Long)
Dim vntTemp As Variant
vntTemp = vntItems(lngItem2)
vntItems(lngItem2) = vntItems(lngItem1)
vntItems(lngItem1) = vntTemp
End Sub
Here’s an example of using this function:
Function sorter(Rng As Range) As Variant
'returns an array
Dim arr1() As Variant
If Rng.Columns.Count > 1 Then Exit Function
arr1 = Application.Transpose(Rng)
QuickSort arr1
sorter = Application.Transpose(arr1)
End Function
Searching for a String Within Text
Ever needed to find out which cells contain a specific string of text? This function can search strings in a range, looking for specified text:
ContainsText(Rng,Text)
It returns a result that identifies which cells contain the text, as shown in Figure 14.14.
These are the arguments:
Rng—The range in which to search
Text—The text for which to search
Function ContainsText(Rng As Range, Text As String) As String
Dim T As String
Dim myCell As Range
For Each myCell In Rng 'look in each cell
If InStr(myCell.Text, Text) > 0 Then 'look in the string for the text
If Len(T) = 0 Then
'if the text is found, add the address to my result
T = myCell.Address(False, False)
Else
T = T & "," & myCell.Address(False, False)
End If
End If
Next myCell
ContainsText = T
End Function
Reversing the Contents of a Cell
This function is mostly fun, but you might find it useful—it reverses the contents of a cell:
ReverseContents(myCell, IsText)
These are the arguments:
myCell—The specified cell
IsText—(Optional) Whether the cell value should be treated as text (default) or a number
Here’s the function’s code:
Function ReverseContents(myCell As Range, _
Optional IsText As Boolean = True)
Dim i As Integer
Dim OrigString As String, NewString As String
OrigString = Trim(myCell) 'remove leading and trailing spaces
For i = 1 To Len(OrigString)
'by adding the variable NewString to the character,
'instead of adding the character to NewString the string is reversed
NewString = Mid(OrigString, i, 1) & NewString
Next i
If IsText = False Then
ReverseContents = CLng(NewString)
Else
ReverseContents = NewString
End If
End Function
Returning the Addresses of Duplicate Max Values
MAX finds and returns the maximum value in a range, but it doesn’t tell you whether there is more than one maximum value. This function returns the addresses of the maximum values in a range, as shown in Figure 14.15:
ReturnMaxs(Rng)
The argument is Rng, the range to search for the maximum values.
Here’s the function’s code:
Function ReturnMaxs(Rng As Range) As String
Dim Mx As Double
Dim myCell As Range
'if there is only one cell in the range, then exit
If Rng.Count = 1 Then ReturnMaxs = Rng.Address(False, False): _
Exit Function
Mx = Application.Max(Rng) 'uses Excel's Max to find the max in the range
'Because you now know what the max value is,
'search the range to find matches and return the address
For Each myCell In Rng
If myCell = Mx Then
If Len(ReturnMaxs) = 0 Then
ReturnMaxs = myCell.Address(False, False)
Else
ReturnMaxs = ReturnMaxs & ", " & myCell.Address(False, False)
End If
End If
Next myCell
End Function
Returning a Hyperlink Address
Let’s say that you’ve received a spreadsheet containing a list of hyperlinked information. You want to see the actual links, not the descriptive text. You could just right-click a hyperlink and select Edit Hyperlink, but you want something more permanent. This function extracts the hyperlink address, as shown in Figure 14.16:
GetAddress(HyperlinkCell)
The argument is HyperlinkCell, the hyperlinked cell from which you want the address extracted.
Function GetAddress(HyperlinkCell As Range)
GetAddress = Replace(HyperlinkCell.Hyperlinks(1).Address, "mailto:", "")
End Function
Returning the Column Letter of a Cell Address
You can use CELL("Col") to return a column number; but what if you need the column letter? This function extracts the column letter from a cell address, as shown in Figure 14.17:
ColName(Rng)
The argument is Rng, the cell for which you want the column letter.
Here’s the function’s code:
Function ColName(Rng As Range) As String
ColName = Left(Rng.Range("A1").Address(True, False), _
InStr(1, Rng.Range("A1").Address(True, False), "$", 1) - 1)
End Function
Using Static Random
The function =RAND() can be very useful for creating random numbers, but it constantly recalculates. What if you need random numbers but don’t want them to change constantly? The following function places a random number, but the number changes only if you force the cell to recalculate, as shown in Figure 14.18:
StaticRAND()
There are no arguments for this function.
Here’s the function’s code:
Function StaticRAND() As Double
Randomize
STATICRAND = Rnd
End Function
Using Select Case on a Worksheet
At some point, you have probably nested an If...Then...Else on a worksheet to return a value. The Select...Case statement available in VBA makes this a lot easier, but you can’t use Select...Case statements in a worksheet formula. Instead, you can create a UDF (see Figure 14.19).
Figure 14.19 Example of using the Select...Case structure in a UDF rather than nested If...Then statements.
This example takes the user input, calculates the BMI (body mass index), and then compares that calculated value to various ranges to return a BMI descriptive, as shown in Figure 14.19. When creating a UDF, think of the formula in the same way you would write it down, because this is very similar to how you enter it in the UDF. The formula for calculating BMI is as follows:
BMI=(weight in pounds*703)/height in inches(squared)
The table for returning the BMI descriptive is as follows:
Below 18.5 = underweight
18.5–24.9 = normal
25–29.9 = overweight
30 & above = obese
The following code calculates the BMI and then returns the descriptive:
Function BMI(Height As Long, Weight As Long) As String
'Do the initial BMI calculation to get the numerical value
calcBMI = (Weight / (Height ^ 2)) * 703
Select Case calcBMI 'evaluate the calculated BMI to get a string value
Case Is <=18.5 'if the calcBMI is less than 18.5
BMI = "Underweight"
Case 18.5 To 24.9 'if the calcBMI is a value between 18.5 and 24.9
BMI = "Normal"
Case 24.9 To 29.9
BMI = "Overweight"
Case Is >= 30 'if the calcBMI is greater than 30
BMI = "Obese"
End Select
End Function
Next Steps
In Chapter 15, “Creating Charts,” you’ll find out how spreadsheet charting has become highly customizable and capable of handling large amounts of data.