Some Useful VBA Functions

Category: VBA Functions | [Item URL]

This tip contains VBA code for six simple, but very useful functions. You can simply copy the code and paste it to your module.

  • FileExists - Returns TRUE if a particular file exists.
  • FileNameOnly- Extracts the filename part of a path/filename string.
  • PathExists - Returns TRUE if a particular path exists.
  • RangeNameExists - Returns TRUE if a particular range name exists.
  • SheetExists - Returns TRUE if a particular sheet exists.
  • WorkBookIsOpen - Returns TRUE if a particular workbook is open.

The FileExists Function

Private Function FileExists(fname) As Boolean
'   Returns TRUE if the file exists
    Dim x As String
    x = Dir(fname)
    If x <> "" Then FileExists = True _
        Else FileExists = False
End Function

The FileNameOnly Function

Private Function FileNameOnly(pname) As String
'   Returns the filename from a path/filename string
    Dim i As Integer, length As Integer, temp As String
    length = Len(pname)
    temp = ""
    For i = length To 1 Step -1
        If Mid(pname, i, 1) = Application.PathSeparator Then
            FileNameOnly = temp
            Exit Function
        End If
        temp = Mid(pname, i, 1) & temp
    Next i
    FileNameOnly = pname
End Function

The PathExists Function

Private Function PathExists(pname) As Boolean
'   Returns TRUE if the path exists
    Dim x As String
    On Error Resume Next
    x = GetAttr(pname) And 0
    If Err = 0 Then PathExists = True _
      Else PathExists = False
End Function

The RangeNameExists Function

Private Function RangeNameExists(nname) As Boolean
'   Returns TRUE if the range name exists
    Dim n As Name
    RangeNameExists = False
    For Each n In ActiveWorkbook.Names
        If UCase(n.Name) = UCase(nname) Then
            RangeNameExists = True
            Exit Function
        End If
    Next n
End Function

The SheetExists Function

Private Function SheetExists(sname) As Boolean
'   Returns TRUE if sheet exists in the active workbook
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then SheetExists = True _
        Else SheetExists = False
End Function

The WorkbookIsOpen Function

Private Function WorkbookIsOpen(wbname) As Boolean
'   Returns TRUE if the workbook is open
    Dim x As Workbook
    On Error Resume Next
    Set x = Workbooks(wbname)
    If Err = 0 Then WorkbookIsOpen = True _
        Else WorkbookIsOpen = False
End Function



Using The GetSetting & SaveSetting Functions

Category: VBA Functions | [Item URL]

The Windows registry is a central storehouse that is used by applications to store information such as user preferences. Prior to Excel 97, accessing the registry required API calls. Excel 97 (and later versions) includes two handy VBA functions:

  • GetSetting: Retrieves a setting from the registry
  • SaveSetting: Saves a setting to the registry

These two functions are described in the online help, so I won't cover the details here. However, it's important to understand that these functions work only with the following key name:

HKEY_CURRENT_USER\Software\VB and VBA Program Settings

In other words, you can't use these functions to access any key in the registry. Rather, these functions are most useful for storing information about your Excel application that you need to maintain between sessions.

An example

The subroutine below, which is stored in the code module for the ThisWorkbook object, demonstrates the GetSetting and SaveSetting functions. This subroutine is executed when the workbook is opened. It retrieves two bits of information: the number of times the workbook has been opened; and the date and time the file was last opened. This information is displayed in a message box.

Private Sub Workbook_Open()
    Dim Counter As Long, LastOpen As String, Msg As String
'   Get setting from registry
    Counter = GetSetting("XYZ Corp", "Budget", "Count", 0)
    LastOpen = GetSetting("XYZ Corp", "Budget", "Opened", "")
 
'   Display the information
    Msg = "This file has been opened " & Counter & " times."
    Msg = Msg & vbCrLf & "Last opened: " & LastOpen
    MsgBox Msg, vbInformation, ThisWorkbook.Name
 
'   Update the information and store it
    Counter = Counter + 1
    LastOpen = Date & " " & Time
    SaveSetting "XYZ Corp", "Budget", "Count", Counter
    SaveSetting "XYZ Corp", "Budget", "Opened", LastOpen
End Sub

The image below shows how these settings appear in the registry (using the Windows regedit.exe program).

http://spreadsheetpage.com/graphics/tips/regedit.gif (5276 bytes)



Determining The Data Type Of A Cell

Category: VBA Functions | [Item URL]

In some situations you may need to determine the type of data in a cell. Excel provides a number of built-in functions that can help. These include ISTEXT, ISLOGICAL, and ISERROR. In addition, VBA includes functions such as IsEmpty, IsDate, and IsNumeric.

The CellType function (VBA code is listed below) accepts a range argument and returns a string that describes the data type of the upper left cell in the range. The function returns one of the following strings: Blank, Text, Logical, Error, Date, Time, or Value.

The CellType function

Function CellType(c)
'   Returns the cell type of the upper left
'   cell in a range
    Application.Volatile
    Set c = c.Range("A1")
    Select Case True
        Case IsEmpty(c): CellType = "Blank"
        Case Application.IsText(c): CellType = "Text"
        Case Application.IsLogical(c): CellType = "Logical"
        Case Application.IsErr(c): CellType = "Error"
        Case IsDate(c): CellType = "Date"
        Case InStr(1, c.Text, ":") <> 0: CellType = "Time"
        Case IsNumeric(c): CellType = "Value"
    End Select
End Function

Using the CellType function

To use this function in a worskheet, just copy the code and paste it to a module. Then, you can enter a formula such as:

=CellType(A1)


A Custom Function For Relative Sheet References

Category: VBA Functions | [Item URL]

You may have discovered that Excel's support for "3D workbooks" is limited. For example, if you need to refer to a different worksheet in a workbook, you must include the worksheet's name in your formula. This is not a big problem -- until you attempt to copy the formula across other worksheets. The copied formulas continue to refer to the original worksheet name.

This tip contains a VBA function (named SHEETOFFSET) that lets you address worksheets in a relative manner. For example, you can refer to cell A1 on the previous worksheet using this formula:

=SHEETOFFSET(-1,A1)

Then, you can copy this formula to other sheets and the relative referencing will be in effect in all of the copied formulas.

The SHEETOFFSET Function

The VBA code for the SHEETOFFSET function is listed below.

Function SHEETOFFSET(offset, Ref)
'   Returns cell contents at Ref, in sheet offset
    Application.Volatile
    With Application.Caller.Parent
        SHEETOFFSET = .Parent.Sheets(.Index + offset) _
         .Range(Ref.Address).Value
    End With
End Function

Using the SHEETOFFSET function

To use this function in a worksheet, just copy the code and paste it to a VBA module. Then, you can use formulas such as:

=SHEETOFFSET(2,C1)

  • The first argument represents the sheet offset, and it can be positive, negative, or 0.
  • The second argument must be a reference to a single cell. If the first argument is 0, the cell reference must not be the same as the cell that contains the formula. If so, you'll generate a circular reference error.

NOTE: Be careful if your workbook contains non-worksheet sheets (for example, chart sheets). If the offset argument results in a reference to a chart sheet, the function will display an error.



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.


Page 2 of 3 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