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

Determining When A File Was Created

Category: VBA Functions | [Item URL]

You probably know that you find out when a file was created by right-clicking the file name in the Windows Explorer, clicking Properties on the context menu.

If you're in Excel, you can determine the creation date of the active workbook by selecting Properties from the File menu. The file creation date appears twice in the Properties dialog box: on the General tab, and on the Statistics tab. In many cases these two dates are different!

• The file creation date and time on the Statistics tab is when the file was originally created.
• The file creation date and time on the General tab is when the file was first saved on your computer.

You can use the VBA statement below to examine the actual file creation date and time (the date and time shown in the Statistics tab):

  MsgBox ActiveWorkbook.BuiltinDocumentProperties.Item _
      ("Creation date").Value

If you'd like to determine the date and time that the file was saved on your computer, you can use the routines listed below. The result is the same date and time that is displayed in the General tab of the Properties dialog box.

You'll need to copy all of the code below to a module. The ShowFile subroutine displays the file creation date and time for the active workbook. You can easily customize this subroutine to show the creation date for any file.

VBA Code

'32 bit Windows declarations
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FileTimeToSystemTime Lib "kernel32" _
    (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Declare Function FileTimeToLocalFileTime Lib "kernel32" _
    (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Long
End Type

Public Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * 260
    cAlternate As String * 14
End Type

Private Function FileDate(FT As FILETIME) As String
'   convert the FILETIME to LOCALTIME, then to SYSTEMTIME type
    Dim ST As SYSTEMTIME
    Dim LT As FILETIME
    Dim t As Long
    Dim ds As Double
    Dim ts As Double
    t = FileTimeToLocalFileTime(FT, LT)
    t = FileTimeToSystemTime(LT, ST)
    If t Then
        ds = DateSerial(ST.wYear, ST.wMonth, ST.wDay)
        ts = TimeSerial(ST.wHour, ST.wMinute, ST.wSecond)
        ds = ds + ts
        If ds > 0 Then
            FileDate = Format$(ds, "mm/dd/yy hh:mm:ss")
        Else
            FileDate = "(no date)"
        End If
    End If
End Function

Private Sub ShowFileInfo()
'   This subroutine demonstrates the technique
    Dim hFile As Long
    Dim WFD As WIN32_FIND_DATA
    Dim FullName As String
    Dim Created As String
    Dim LastWrite As String
     
'   FullName is the path and filename
'   Substitute any valid file and path
    FullName = ActiveWorkbook.FullName
    hFile = FindFirstFile(FullName, WFD)
    If hFile > 0 Then
        Created = FileDate(WFD.ftCreationTime)
        MsgBox "File Created: " & Created, vbInformation, FullName
    Else
        MsgBox "File not found.", vbCritical, FullName
    End If
End Sub

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).

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.

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.

Page 2 of 3 pages
[Previous page]   [Next page]