Excel provides many built-in formulas, but sometimes you need a complex custom formula not offered—for example, a formula 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—beware you don’t enter the same number twice! Both methods are time-consuming and prone to accidents. What to do? You could write a procedure—after all, that’s what this book is about. But, you have another option: user-defined functions (UDFs).
You can create functions in VBA that can be used just like 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.
Note
UDFs can be entered only into standard modules. Sheet and ThisWorkbook modules are a special type of module; if you enter the function there, Excel won’t recognize that you are creating a UDF.
Custom Functions—Example and Explanation
Let’s build a custom function used to add two values. After we’ve created it, we’ll use it on a worksheet.
Insert a new module in the VB Editor. Type the following function into the module. It is a function called ADD that will total two numbers in different cells. The function has two arguments:
Add(Number1,Number2)
Number1 is the first number to add; Number2 is the second number to add:
Function Add(Number1 As Integer, Number2 As Integer) As Integer Add = Number1 + Number2 End Function
Let’s break this down:
Function name:
ADD.Arguments are placed in parentheses after the name of the function. This example has two arguments:
Number1andNumber2.As Integerdefines the variable type of the result as a whole number.ADD =Number1 + Number2: The result of the function is returned.
Here is how to use the function on a worksheet:
Type numbers into cells A1 and A2.
Select cell A3.
Press Shift+F3 to open the Paste Function dialog box (or from the Formulas ribbon, choose Insert Function).
Select the User Defined category (see Figure 4.1).
Select the
ADDfunction.In the first argument box, select cell A1 (see Figure 4.2).
In the second argument box, select cell A2.
Click OK.
Congratulations! You have created your first custom function.
Note
You can easily share custom functions because the 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 same functions used on sheets can also be used in VBA and vice versa. In VBA, however, you call the UDF (ADD) from a procedure (Addition):
Sub Addition () Dim Total as Integer Total = Add (1,10) 'we use a user-defined function Add MsgBox "The answer is: " & Total End Sub
Where you store a UDF affects how you can share it:
Personal.xlsb—. If the UDF is just for your use and won’t be used in a workbook opened on another computer, you can store the UDF in the Personal.xlsb.
Workbook—. If the UDF needs to be distributed to many people, you can store it in the workbook in which it is being used.
Add-in—. If the workbook is to be shared among a select group of people, you can distribute it via an add-in (see Chapter 27, “Creating Add-Ins” for information on how to create an add-in).
Template—. If several workbooks need to be created using the UDF and the workbooks are distributed to many people, you can store it in a template.
The sections that follow include a sampling of functions that can be useful in the everyday Excel world.
This chapter contains functions donated by several Excel programmers. These are functions that they have found useful and that they hope will be of help to you, too.
Different programmers have different programming styles and 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.
The following function is to set the name of the active workbook in a cell, as shown in Figure 4.3:
MyName()
No arguments are used with this function:
Function MyName() As String
MyName = ThisWorkbook.Name
End FunctionA variation of the previous function, this one sets the file path and name of the active workbook in a cell, as shown previously in Figure 4.3:
MyFullName()
No arguments are used with this function:
Function MyFullName() As String
MyFullName = ThisWorkbook.FullName
End FunctionThere might be times when you need to check whether a workbook is open. The following function returns True if the workbook is open and False if it is not:
BookOpen(Bk)
The argument is Bk, 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 = "ProjectFilesChapter04.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 SubThis 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)
The arguments are as follows:
SName—. The name of the sheet being searchedWBName—. (Optional) The name of the workbook containing the sheet
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 FunctionHere is an example of using this function:
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 SubThis function searches the current directory, and its subfolders if you want, counting all Excel macro workbook files (XLSM) or just the ones starting with a string of letters:
NumFilesInCurDir (LikeText, Subfolders)
The arguments are as follows:
LikeText—. (Optional) A string value to search for, must include an asterisk (*); for example:Mr*Subfolders—. (Optional)Trueto search subfolders,False(default) not to
Note
FileSystemObject requires the Microsoft Scripting Runtime reference library. To enable this setting, go to Tools, References and check Microsoft Scripting Runtime.
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 FunctionHere is an example of using this function:
Sub CountMyWkbks()
Dim MyFiles As Integer
MyFiles = NumFilesInCurDir("MrE*", True)
MsgBox MyFiles & " file(s) found"
End SubEver need to keep a record of who saves changes to a workbook? With the USERID function, you can retrieve the name of the user logged in to a computer. Combine it with function discussed in the “Retrieve Permanent Date and Time” section and you’ll have a nice log file. You can also use it to set up user rights to a workbook:
WinUserName ()
No arguments are used with this function.
Note
This function is an advanced function that uses the application programming interface (API), which we will review in Chapter 24, “Windows Application Programming Interface (API).”
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 previous 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 FunctionSub 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 SubThis function retrieves the saved date and time of any workbook, including the current one, as shown in Figure 4.4.
LastSaved(FullPath)
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
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 gets updated. The following function uses the NOW function; but because you need to reenter the cell to update the function, it is much less volatile, as shown in Figure 4.5:
DateTime()
No arguments are used with this function:
DateTime()
Function example:
Function DateTime()
DateTime = Now
End FunctionIf you manage an email subscription list, you may 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 4.6):
Caution
This function cannot verify that an email address is an existing one. It only checks the syntax to verify that the address may be legitimate.
IsEmailValid (StrEmail)
The 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 FunctionYou have a list of clients and how much each owes you. You’ve colored in the amounts of the clients that are 30 days past due and want to sum up just those cells.
SumColor(CellColor, SumRange)
The arguments are as follows:
CellColor—. The address of a cell with the target colorSumRange—. 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 FunctionFigure 4.7 shows an example worksheet using this function.
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 tells you just that, as shown in Figure 4.8:
NumUniqueValues(Rng)
The argument is Rng, the range to search unique values.
Function example:
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 FunctionHow often have you 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 to remove duplicates.
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 previous section:
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 FunctionHere is an example of using this function. See Figure 4.9 for the result on a worksheet:
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
You import a large list of data with a lot of empty cells. Here is a function that evaluates a range of cells and returns the value of the first non-zero-length cell:
FirstNonZeroLength(Rng)
The argument is Rng, the range to search.
Function example:
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 FunctionFigure 4.10 shows the function on an example worksheet.
Excel has a substitute function, but it is a value-for-value substitution. What if you have several characters you need to substitute? Figure 4.11 shows several examples of how this function works:
MSubstitute(trStr, frStr, toStr)
The arguments are as follows:
trStr—. The string to be searchedfrStr—. The text being searched fortoStr—. The replacement text
Caution
toStr is assumed to be the same length as frStr. If not, the remaining characters are considered null (""). The function is case sensitive. To replace all instances of a, use a and A. You can’t replace one character with two characters. This
=MSUBSTITUTE("This is a test","i","$@")results in this:
"Th$s $s a test"
Function example:
Function MSUBSTITUTE(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 FunctionThis function extracts and returns numbers from text that is a mix of numbers and letters, as shown in Figure 4.12:
RetrieveNumbers (myString)
The argument is myString, the text containing the numbers to be extracted.
Function example:
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 FunctionEver receive a spreadsheet report and all the headers showed the week number? I don’t know about you, but I don’t know what Week 15 actually is. I would have to get out my calendar and count the weeks. And what if you need to look at a past year? What we need is a nice little function that will convert Week ## Year into the date of the Monday for that week, as shown in Figure 4.13:
Weekday(Str)
The argument is Str, the week to be converted in "Week ##, YYYY" format.
Function example:
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
In this example, you need to paste a column of delimited data. You could use Excel’s Text to Columns, but you need only an element or two from each cell. Text to Columns parses the entire thing. What you need is a function that lets you specify the number of the element in a string that you need, as shown in Figure 4.14:
StringElement(str,chr,ind)
The arguments are as follows:
str—. The string to be parsedchr—. The delimiterind—. The position of the element to be returned
Function example:
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
What about taking a column of data, sorting it, and concatenating it, using a comma (,) as the delimiter (see Figure 4.15)?
SortConcat(Rng)
The argument is Rng, the range of data to be sorted and concatenated. SortConcat calls another procedure, BubbleSort, that must be included.
Function example:
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 FunctionThe following function is the ever-popular BubbleSort, a program used by many 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 UCase(List(i)) > UCase(List(j)) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End SubThis function takes a mixed range of numeric and alpha characters and sorts them—numerically first and then alphabetically. The result is placed in an array that can be displayed on a worksheet through the use of an array formula, as shown in Figure 4.16:
sorter(Rng)
The argument is Rng, the range to be sorted.
Function example:
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
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 SubEver needed to find out which cells contain a specific string of text? This function can search strings in a range, looking for specified text. It returns a result identifying which cells contain the text, as shown in Figure 4.17:
ContainsText(Rng,Text)
The arguments are as follows:
Rng—. The range in which to searchText—. The text for which to search
Function example:
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 FunctionThis function is mostly fun, but you might find it useful—it reverses the contents of a cell:
ReverseContents(myCell, IsText)
The arguments are as follows:
myCell—. The specified cellIsText—. (Optional) Whether the cell value should be treated as text (default) or a number
Function example:
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 NewStringthe string is reversed
NewString = Mid(OrigString, i, 1) & NewString
Next i
If IsText = False Then
ReverseContents = CLng(NewString)
Else
ReverseContents = NewString
End If
End FunctionMAX 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 address(es) of the maximum value(s) in a range, as shown in Figure 4.18:
ReturnMaxs(Rng)
The argument is Rng, the range to search for the maximum value(s).
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 ranging finding 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 FunctionYou’ve received a spreadsheet with a list of hyperlinked information. You want to see the actual links, not the descriptive text. You could just right-click it and choose Edit Hyperlink, but you want something more permanent. This function extracts the hyperlink address, as shown in Figure 4.19:
GetAddress(Hyperlink)
The argument is Hyperlink, the hyperlinked cell from which you want the address extracted.
Function GetAddress(HyperlinkCell As Range)
GetAddress = Replace(HyperlinkCell.Hyperlinks(1).Address, "mailto:", "")
End FunctionYou 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 4.20:
ColName(Rng)
The argument is Rng, the cell for which you want the column letter.
Function example:
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 FunctionThe function =RAND() can prove 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 4.21:
StaticRAND()
There are no arguments for this function.
Function example:
Function StaticRAND() As Double Randomize STATICRAND = Rnd End Function
Have you ever nested an If...Then...Else on a worksheet to return a value? The Select...Case statement available in VBA case 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 4.22).
The following function shows how you can use Select statements to produce the results of a nested If...Then statement:
Function state_period(mth As Integer, yr As Integer)
Select Case mth
Case 1
state_period = "July 1, " & yr - 1 & " through July 31, " & yr - 1
Case 2
state_period = "August 1, " & yr - 1 & " through August 31, " & yr - 1
Case 3
state_period = "September 1, " & yr - 1 & " through September 30, " & yr - 1
Case 4
state_period = "October 1, " & yr - 1 & " through October 31, " & yr - 1
Case 5
state_period = "November 1, " & yr - 1 & " through November 30, " & yr - 1
Case 6
state_period = "December 1, " & yr - 1 & " through December 31, " & yr - 1
Case 7
state_period = "January 1, " & yr & " through January 31, " & yr
Case 8
state_period = "February 1, " & yr & " through February 28, " & yr
Case 9
state_period = "March 1, " & yr & " through March 31, " & yr
Case 10
state_period = "April 1, " & yr & " through April 30, " & yr
Case 11
state_period = "May 1, " & yr & " through May 31, " & yr
Case 12
state_period = "June 1, " & yr & " through June 30, " & yr
Case 13
state_period = "Pre-Final"
Case 14
state_period = "Closeout"
End Select
End FunctionThe next chapter describes a fundamental component of any programming language: loops. You will be familiar with basic loop structures if you’ve taken any programming classes, and VBA supports all the usual loops. You will also learn about a special loop, For Each...Next, which is unique to object-oriented programming, such as VBA.