Determining If A Range Is Contained In A Range
In some situations, you may need to determine if a particular range is contained within another range. For example, you may need to determine if the active cell is in a particular range.
The InRange function, listed below, accepts two arguments (both Range objects). The function returns True if the first range is contained in the second range. Notice that the function checks to make sure that the two range arguments are contained in the same sheet and in the same workbook.
You can use the InRange function in your VBA code, or in a worksheet function.
The InRange Function
The VBA code for the InRange function is listed below.
Function InRange(rng1, rng2) As Boolean ' Returns True if rng1 is a subset of rng2 InRange = False If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then If rng1.Parent.Name = rng2.Parent.Name Then If Union(rng1, rng2).Address = rng2.Address Then InRange = True End If End If End If End Function
Listed below is a simple example that uses the InRange function. The subroutine prompts the user to select a range, and then checks the range using the InRange function. If the user's selection is not within A1:E20, the prompt appears again.
Sub Test() Dim ValidRange As Range, UserRange As Range Dim SelectionOK As Boolean Set ValidRange = Range("A1:E20") SelectionOK = False On Error Resume Next Do Until SelectionOK = True Set UserRange = Application.InputBox(Prompt:="Select a range", Type:=8) If TypeName(UserRange) = "Empty" Then Exit Sub If InRange(UserRange, ValidRange) Then MsgBox "The range is valid." SelectionOK = True Else MsgBox "Select a range within " & ValidRange.Address End If Loop End Sub
Determining If A Worksheet Or Workbook Has Code
Every workbook and sheet has a corresponding code module. These code modules can contain VBA code to handle workbook or sheet-level events. For example, a workbook code module (named ThisWorkbook by default) might have a subroutine declared as follows:
Private Sub Workbook_Open() ' Code goes here End Sub
The Workbook_Open sub is executed whenever the workbook is opened.
Similarly, code modules for worksheets can contain subroutines to handle worksheet event such as Activate, Deactivate, Change, etc.
Listed below are two custom VBA functions that you can use to determine if the code module for a particular workbook or worksheet contains any code.
The WorkbookHasVBACode Function
The function below takes a single argument: a workbook object. It returns True if the workbook's code module contains any VBA code.
Private Function WorkbookHasVBACode(wb As Workbook) ModuleLineCount = wb.VBProject.VBComponents(wb.CodeName). _ CodeModule.CountOfLines If ModuleLineCount = 0 Then WorkbookHasVBACode = False Else WorkbookHasVBACode = True End If End Function
The SheetHasVBACode Function
The function below takes a single argument: a worksheet object. It returns True if the worksheet's code module contains any VBA code.
Private Function SheetHasVBACode(wks As Worksheet) ModuleLineCount = wks.Parent.VBProject. _ VBComponents(wks.CodeName).CodeModule.CountOfLines If ModuleLineCount = 0 Then SheetHasVBACode = False Else SheetHasVBACode = True End If End Function
The example below demonstrates a practical use of the SheetHasVBACode function. The DeleteBlankSheets subroutine deletes all blank sheets in the active workbook -- but only if the sheet does not contain any VBA code.
Sub DeleteBlankSheets() Dim sht As Worksheet On Error GoTo ErrHandler ' Avoid Excel's confirmation prompt Application.DisplayAlerts = False ' Loop through each sheet For Each sht In ActiveWorkbook.Worksheets ' Is non-blank cell count zero? If Application.CountA(sht.Cells) = 0 Then ' Don't try to delete the last sheet If ActiveWorkbook.Sheets.Count <> 1 Then ' Don't delete sheet if it has VBA code If Not SheetHasVBACode(sht) Then sht.Delete End If End If End If Next sht Exit Sub ErrHandler: MsgBox sht.Name & Chr(13) & Chr(13) & Error(Err) End Sub
Searching Using Soundex Codes
A companion file is available: Click here to download
Soundex is an indexing system that translates a name into a 4-digit code consisting of one letter and three numbers. The advantage of Soundex is its ability to locate names by the way they sound, rather than by exact spelling. For example, consider the name Maris. This name has a Soundex code of M620. Other variations on this name (such as Mares, Marriss, Mariss, and Mairis) all have the same Soundex code.
- Each Soundex code has exactly four alphanumeric characters (1 letter and 3 numbers)
- The first letter of the name is always the first character of the Soundex code.
- The remaining three digits are defined from the name using the Soundex Key Codes listed below.
- Adjacent letters in the name which have the same Soundex Key code number are assigned a single digit.
- If the name is not long enough to yield four characters,the code is padded with zeros.
|1||B F P V|
|2||C G J K Q S X Z|
|No code||A E H I O U Y W|
The SOUNDEX function
This document presents a VBA function (named SOUNDEX) that converts a text string into a Soundex code. This function was developed by Richard J. Yanco.
The function can be used in a worksheet formula, or called from a VBA procedure. The SOUNDEX function is listed below. Notice that this function calls another function named Category.
Function SOUNDEX(Surname As String) As String ' Developed by Richard J. Yanco ' This function follows the Soundex rules given at ' http://home.utah-inter.net/kinsearch/Soundex.html Dim Result As String, c As String * 1 Dim Location As Integer Surname = UCase(Surname) ' First character must be a letter If Asc(Left(Surname, 1)) < 65 Or Asc(Left(Surname, 1)) > 90 Then SOUNDEX = "" Exit Function Else ' St. is converted to Saint If Left(Surname, 3) = "ST." Then Surname = "SAINT" & Mid(Surname, 4) End If ' Convert to Soundex: letters to their appropriate digit, ' A,E,I,O,U,Y ("slash letters") to slashes ' H,W, and everything else to zero-length string Result = Left(Surname, 1) For Location = 2 To Len(Surname) Result = Result & Category(Mid(Surname, Location, 1)) Next Location ' Remove double letters Location = 2 Do While Location < Len(Result) If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then Result = Left(Result, Location) & Mid(Result, Location + 2) Else Location = Location + 1 End If Loop ' If category of 1st letter equals 2nd character, remove 2nd character If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then Result = Left(Result, 1) & Mid(Result, 3) End If ' Remove slashes For Location = 2 To Len(Result) If Mid(Result, Location, 1) = "/" Then Result = Left(Result, Location - 1) & Mid(Result, Location + 1) End If Next ' Trim or pad with zeroes as necessary Select Case Len(Result) Case 4 SOUNDEX = Result Case Is < 4 SOUNDEX = Result & String(4 - Len(Result), "0") Case Is > 4 SOUNDEX = Left(Result, 4) End Select End If End Function Private Function Category(c) As String ' Returns a Soundex code for a letter Select Case True Case c Like "[AEIOUY]" Category = "/" Case c Like "[BPFV]" Category = "1" Case c Like "[CSKGJQXZ]" Category = "2" Case c Like "[DT]" Category = "3" Case c = "L" Category = "4" Case c Like "[MN]" Category = "5" Case c = "R" Category = "6" Case Else 'This includes H and W, spaces, punctuation, etc. Category = "" End Select End Function
The demo file (linked above) contains a list of more than 4,000 names. You can search for a name in the list, and specify an exact match or an approximate match.
If you choose an approximate match, you'll get a list of names that have the same Soundex code as the name you're searching for.
Getting A List Of Installed Fonts
Your VBA procedure might need to present the user with a list of fonts to choose from. Or, you may need to determine if a particular font is installed. The simplest way to access the installed font list is to get the fonts from the Font control on the Formatting toolbar. The Font control contains a dropdown list of installed fonts, and you can write VBA code to retrieve that list from the control.
Displaying font names
The procedure listed below displays a list of installed fonts in Column A of the active worksheet. It uses the FindControl method to locate the Font control on the Formatting toolbar. If this control is not found (i.e., it was removed by the user) a temporary CommandBar is created and the Font control is added to it.
Sub ShowInstalledFonts() Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728) ' If Font control is missing, create a temp CommandBar If FontList Is Nothing Then Set TempBar = Application.CommandBars.Add Set FontList = TempBar.Controls.Add(ID:=1728) End If ' Put the fonts into column A Range("A:A").ClearContents For i = 0 To FontList.ListCount - 1 Cells(i + 1, 1) = FontList.List(i + 1) Next i ' Delete temp CommandBar if it exists On Error Resume Next TempBar.Delete End Sub
Is a font installed?
The function below uses the same technique as the ShowInstalledFonts procedure. it returns True if a specified font is installed.
Function FontIsInstalled(sFont) As Boolean ' Returns True if sFont is installed FontIsInstalled = False Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728) ' If Font control is missing, create a temp CommandBar If FontList Is Nothing Then Set TempBar = Application.CommandBars.Add Set FontList = TempBar.Controls.Add(ID:=1728) End If For i = 0 To FontList.ListCount - 1 If FontList.List(i + 1) = sFont Then FontIsInstalled = True On Error Resume Next TempBar.Delete Exit Function End If Next i ' Delete temp CommandBar if it exists On Error Resume Next TempBar.Delete End Function
The statement below demonstrates how to use this function in a VBA procedure. It displays True in a message box if the user's system contains the Comic Sans MS font.
MsgBox FontIsInstalled("Comic Sans MS")
A VBA Function To Get A Value From A Closed File
VBA does not include a method to retrieve a value from a closed file. You can, however, take advantage of Excel's ability to work with linked files.
This tip contains a VBA function that retrieves a value from a closed workbook. It does by calling an XLM macro.
Note: You cannot use this function in a worksheet formula.
The GetValue Function
The GetValue function, listed below takes four arguments:
- path: The drive and path to the closed file (e.g., "d:\files")
- file: The workbook name (e.g., "budget.xls")
- sheet: The worksheet name (e.g., "Sheet1")
- ref: The cell reference (e.g., "C4")
Private Function GetValue(path, file, sheet, ref) ' Retrieves a value from a closed workbook Dim arg As String ' Make sure the file exists If Right(path, 1) <> "\" Then path = path & "\" If Dir(path & file) = "" Then GetValue = "File Not Found" Exit Function End If ' Create the argument arg = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(ref).Range("A1").Address(, , xlR1C1) ' Execute an XLM macro GetValue = ExecuteExcel4Macro(arg) End Function
Using the GetValue Function
To use this function, copy the listing to a VBA module. Then, call the function with the appropriate arguments. The Sub procedure below demonstrates. It simply displays the value in cell A1 in Sheet1 of a file named Budget.xls, located in the XLFiles\Budget directory on drive C:.
Sub TestGetValue() p = "c:\XLFiles\Budget" f = "Budget.xls" s = "Sheet1" a = "A1" MsgBox GetValue(p, f, s, a) End Sub
Another example is shown below. This procedure reads 1,200 values (100 rows and 12 columns) from a closed file, and places the values into the active worksheet.
Sub TestGetValue2() p = "c:\XLFiles\Budget" f = "Budget.xls" s = "Sheet1" Application.ScreenUpdating = False For r = 1 To 100 For c = 1 To 12 a = Cells(r, c).Address Cells(r, c) = GetValue(p, f, s, a) Next c Next r Application.ScreenUpdating = True End Sub
In order for this function to work properly, a worksheet must be active in Excel. It will generate an error if all windows are hidden, or if the active sheet is a Chart sheet.
Playing A Sound Based On A Cell’s Value
Some people like audio feedback. For example, you might want to hear a sound when the value in a particular cell exceeds a certain value. Excel does not support this feature, but it's fairly easy to implement with a custom worksheet function that uses a Windows API function.
The Alarm function
Copy the code below to a VBA module in your workbook.
'Windows API function declaration Private Declare Function PlaySound Lib "winmm.dll" _ Alias "PlaySoundA" (ByVal lpszName As String, _ ByVal hModule As Long, ByVal dwFlags As Long) As Long Function Alarm(Cell, Condition) Dim WAVFile As String Const SND_ASYNC = &H1 Const SND_FILENAME = &H20000 On Error GoTo ErrHandler If Evaluate(Cell.Value & Condition) Then WAVFile = ThisWorkbook.Path & "\sound.wav" 'Edit this statement Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME) Alarm = True Exit Function End If ErrHandler: Alarm = False End Function
NOTE: The Alarm function expects a WAV file (named sound.wav) in the same path as the workbook. You will need to change this statement to match the name (and path) of your actual sound file. If the sound file is not found, the default system sound will be used.
Using the Alarm function in a formula
The Alarm function monitors a cell for a specified condition. If the condition is met, the sound file is played and the function returns TRUE. If the condition is not met, the sound file is not played and the function returns FALSE. The Alarm function takes two arguments:
- Cell: A reference to a single cell (the cell that you are monitoring). Normally, this will be a cell that contains a formula (but that is not required).
- Condition: A text string that describes the condition
Following are examples of formulas that use this function:
The sound will play when the value in cell A1 is greater than or equal to 1,000.
The sound will play when the value in cell C12 is negative.
- The function is evaluated whenever any cell that depends on the reference cell is changed. The sound can get annoying!
- Normally, you will want to use this function in only one cell. If you use it in more than one cell, you will not be able to tell which instance of the function triggered the sound.
Determining The Drive Type
A companion file is available: Click here to download
This tip contains a VBA function that uses the Windows GetDriveType API function to determine the type of a particular drive.
Private Declare Function GetDriveType Lib "kernel32" _ Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Function DriveType(DriveLetter As String) As String ' Returns a string that describes the type of drive of DriveLetter DriveLetter = Left(DriveLetter, 1) & ":\" Select Case GetDriveType(DriveLetter) Case 0: DriveType = "Unknown" Case 1: DriveType = "Non-existent" Case 2: DriveType = "Removable drive" Case 3: DriveType = "Fixed drive" Case 4: DriveType = "Network drive" Case 5: DriveType = "CD-ROM drive" Case 6: DriveType = "RAM disk" Case Else: DriveType = "Unknown drive type" End Select End Function
The function accepts a drive letter, and returns a string that describes the type of drive. Network drives must be mapped to a single-letter drive designator.
The example below lists all drives, and their type. The information is sent to columns A and B of the active worksheet.
Sub ShowAllDrives() Dim LetterCode As Long Dim Row As Long Dim DT As String Row = 1 For LetterCode = 65 To 90 ' A-Z DT = DriveType(Chr(LetterCode)) If DT <> "Non-existent" Then Cells(Row, 1) = Chr(LetterCode) & ":\" Cells(Row, 2) = DT Row = Row + 1 End If Next LetterCode End Sub
The downloadable file also contains functions that return the total drive size, and space available.
The Versatile Split Function
A simple example
The procedure below demonstrates how the Split function works.
Sub SplitDemo() Dim txt As String Dim x As Variant Dim i As Long txt = "The Split function is versatile" x = Split(txt, " ") For i = 0 To UBound(x) Debug.Print x(i) Next i End Sub
This procedures displays the output shown below.
In this case, the delimiter is a space character. You can specify any character or string to be used as the delimiter. The following examples demonstrate some other uses for the Split function.
Extracting an element
Split is a VBA function, so it can't be used in a worksheet formula. The function below is simply a "wrapper" for the Split function, so your formulas can make use of this handy function.
Function ExtractElement(str, n, sepChar) ' Returns the nth element from a string, ' using a specified separator character Dim x As Variant x = Split(str, sepChar) If n > 0 And n - 1 <= UBound(x) Then ExtractElement = x(n - 1) Else ExtractElement = "" End If End Function
The formula below demonstrates how the ExtractElement function can be used in a formula.
This formula returns 909, the third element in the string (which uses a "-" as the delimiter).
The function below returns the number of words in a string. It uses Excel's TRIM function to remove excess spaces (which would cause an incorrect result).
Function WordCount(txt) As Long ' Returns the number of words in a string Dim x As Variant txt = Application.Trim(txt) x = Split(txt, " ") WordCount = UBound(x) + 1 End Function
Splitting up a filename
The two examples in this section make it easy to extract a path or a filename from a full filespec, such as "c:\files\workbooks\archives\budget98.xls"
Function ExtractFileName(filespec) As String ' Returns a filename from a filespec Dim x As Variant x = Split(filespec, Application.PathSeparator) ExtractFileName = x(UBound(x)) End Function Function ExtractPathName(filespec) As String ' Returns the path from a filespec Dim x As Variant x = Split(filespec, Application.PathSeparator) ReDim Preserve x(0 To UBound(x) - 1) ExtractPathName = Join(x, Application.PathSeparator) & _ Application.PathSeparator End Function
Using the filespec shown above as the argument, ExtractFileName returns "budget98.xls" and ExtractPathName returns "c:\files\workbooks\archives\"
Counting specific characters in a string
The function below accepts a string and a substring as arguments, and returns the number of times the substring is contained in the string.
Function CountOccurrences(str, substring) As Long ' Returns the number of times substring appears in str Dim x As Variant x = Split(str, substring) CountOccurrences = UBound(x) End Function
Finding the longest word
The function below accepts a sentence, and returns the longest word in the sentence.
Function LongestWord(str) As String ' Returns the longest word in a string of words Dim x As Variant Dim i As Long str = Application.Trim(str) x = Split(str, " ") LongestWord = x(0) For i = 1 To UBound(x) If Len(x(i)) > Len(LongestWord) Then LongestWord = x(i) End If Next i End Function
Retrieving The Computer Name Or Logged-in User Name
This tip uses two Windows API functions to return the name of the computer, and the name of the user who is currently logged in. These functions can be used in a worksheet formula, or called from a VBA procedure.
NOTE: The logged-in user name may or may not be the name that is returned by Application.User
Private Declare Function GetComputerName Lib "kernel32" _ Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) _ As Long Private Declare Function GetUserName Lib "advapi32.dll" _ Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) _ As Long
Public Function NameOfComputer() ' Returns the name of the computer Dim ComputerName As String Dim ComputerNameLen As Long Dim Result As Long ComputerNameLen = 256 ComputerName = Space(ComputerNameLen) Result = GetComputerName(ComputerName, ComputerNameLen) If Result <> 0 Then NameOfComputer = Left(ComputerName, ComputerNameLen) Else NameOfComputer = "Unknown" End If End Function Function UserName() As String ' Returns the name of the logged-in user Dim Buffer As String * 100 Dim BuffLen As Long BuffLen = 100 GetUserName Buffer, BuffLen UserName = Left(Buffer, BuffLen - 1) End Function
Identifying The Newest File In A Directory
The VBA function listed below (two versions) returns the name of the most recent file in a directory. The function takes two arguments:
- Directory: The full path of the directory (String). For example, "c:\files\excel\"
- FileSpec: The file specification (String). For example, "*.xls" for Excel workbooks, or "*.*" for all files.
If the directory does not exist, or if it contains no matching files, the function returns an empty string.
Method 1: Using the Dir function
This function uses VBA's Dir function to get the file names. Use this function for maximum compatibility with older versions of Excel.
Function NewestFile(Directory, FileSpec) ' Returns the name of the most recent file in a Directory ' That matches the FileSpec (e.g., "*.xls"). ' Returns an empty string if the directory does not exist or ' it contains no matching files Dim FileName As String Dim MostRecentFile As String Dim MostRecentDate As Date If Right(Directory, 1) <> "\" Then Directory = Directory & "\" FileName = Dir(Directory & FileSpec, 0) If FileName <> "" Then MostRecentFile = FileName MostRecentDate = FileDateTime(Directory & FileName) Do While FileName <> "" If FileDateTime(Directory & FileName) > MostRecentDate Then MostRecentFile = FileName MostRecentDate = FileDateTime(Directory & FileName) End If FileName = Dir Loop End If NewestFile = MostRecentFile End Function
Method 2: Using the FileSearch object
This function uses the FileSearch object, which is not supported in all versions of Excel. Unlike the previous version of the function, this one returns the full path as well as the file name.
Also, be aware that the FileSearch object was removed, beginning with Office 2007.
Function NewestFile(Directory, FileSpec) ' Returns the full path and name of the most recent file in a Directory ' That matches the FileSpec (e.g., "*.xls"). ' Returns an empty string if the directory does not exist or ' it contains no matching files Dim NumFound As Long NewestFile = "" With Application.FileSearch .NewSearch .LookIn = Directory .FileName = FileSpec NumFound = .Execute(SortBy:=msoSortByLastModified, _ SortOrder:=msoSortOrderDescending) If NumFound > 0 Then NewestFile = .FoundFiles(1) End With End Function
This function can be called from a VBA procedure, or used in a worksheet formula. The statement below displays the name of the most recent Excel file in c:\myfiles\.
MsgBox NewestFile("c:\myfiles", "*.xls")
The worksheet formula below displays the same filename.
Search for Tips
Browse Tips by Category
Needs tips? Here are two books, with nothing but tips:
Contains more than 200 useful tips and tricks for Excel 2007 | Other Excel 2007 books | Amazon link: John Walkenbach's Favorite Excel 2007 Tips & Tricks