Determining If A Range Is Contained In A Range

Category: VBA Functions | [Item URL]

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

An Example

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

Category: VBA Functions | [Item URL]

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

An Example

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

Category: VBA Functions | [Item URL]

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.

Soundex Rules

  1. Each Soundex code has exactly four alphanumeric characters (1 letter and 3 numbers)
  2. The first letter of the name is always the first character of the Soundex code.
  3. The remaining three digits are defined from the name using the Soundex Key Codes listed below.
  4. Adjacent letters in the name which have the same Soundex Key code number are assigned a single digit.
  5. If the name is not long enough to yield four characters,the code is padded with zeros.
Code Letter
1 B F P V
2 C G J K Q S X Z
3 D T
4 L
5 M N
6 R
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

Category: VBA Functions | [Item URL]

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

Category: VBA Functions | [Item URL]

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

Caveat

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

Category: VBA Functions | [Item URL]

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:

=Alarm(A1,">=1000")

The sound will play when the value in cell A1 is greater than or equal to 1,000.

=Alarm(C12,"<0")

The sound will play when the value in cell C12 is negative.

Tips

  • 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

Category: VBA Functions | [Item URL]

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.

Example

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

Category: VBA Functions | [Item URL]

VBA's Split function, introduced with Excel 2000, can simplify many programming tasks. This function accepts a text string, and returns a zero-based variant array that contains the elements of the string (you specify the character that delimits the elements).

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.

  =ExtractElement("546-339-909-944",3,"-")

This formula returns 909, the third element in the string (which uses a "-" as the delimiter).

Counting words

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

Category: VBA Functions | [Item URL]

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

API Declarations

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

The Functions

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

Category: VBA Functions | [Item URL]

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

Usage Examples

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.

    =NewestFile("c:\myfiles", "*.xls")


Page 8 of 17 pages
[Previous page]   [Next page]

Search for Tips


All Tips

Browse Tips by Category

Tip Books

Needs tips? Here are two books, with nothing but tips:

Contains more than 100 useful tips and tricks for Excel 2013 | Other Excel 2013 books | Amazon link: 101 Excel 2013 Tips, Tricks & Timesavers

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

© Copyright 2017, J-Walk & Associates, Inc.
Privacy Policy