User-Defined Function Argument Descriptions In Excel 2010

Category: VBA Functions | [Item URL]

One of the new features in Excel 2010 is the ability to provide argument descriptions for user-defined functions. These descriptions appear in Function Arguments dialog box -- which is displayed after you choose a function using the Insert Function dialog box.

Here's a simple (but very useful) user-defined function:

Function EXTRACTELEMENT(Txt, n, Separator) As String
     EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function

Here's a VBA macro that provides a description for the EXTRACTELEMENT function, assigns it to a function category, and provides a description for each of its three arguments:

Sub DescribeFunction()
   Dim FuncName As String
   Dim FuncDesc As String
   Dim Category As String
   Dim ArgDesc(1 To 3) As String

   FuncName = "EXTRACTELEMENT"
   FuncDesc = "Returns the nth element of a string that uses a separator character"
   Category = 7 'Text category
   ArgDesc(1) = "String that contains the elements"
   ArgDesc(2) = "Element number to return"
   ArgDesc(3) = "Single-character element separator"

   Application.MacroOptions _
      Macro:=FuncName, _
      Description:=FuncDesc, _
      Category:=Category, _
      ArgumentDescriptions:=ArgDesc
End Sub

You need to run this macro only one time. After doing so, the descriptive information is stored in the workbook (or add-in) that defines the function.

Here's how the function appears in the Function Arguments dialog box:

What about compatibility with earlier versions?

If the file is opened in Excel 2007, the argument descriptions are not displayed. If you save the workbook as an XLS file, the Compatibility Checker kicks in and tells you that the function descriptions will be removed.

Extracting An Email Address From Text

Category: VBA Functions | [Item URL]

This tip describes a VBA function that accepts a text string as input, and returns the first email address found in the text. The figure below shows this function in use. The formula in cell B2 is:

=ExtractEmailAddress(A2)

If an email address is not found, the function returns an empty string. Also, note that it only extracts the first email address.

The function is not very elegant. It just starts with the first "at symbol" it finds, and examines the characters before and after the at symbol.

Function ExtractEmailAddress(s As String) As String
    Dim AtSignLocation As Long
    Dim i As Long
    Dim TempStr As String
    Const CharList As String = "[A-Za-z0-9._-]"
    
    'Get location of the @
    AtSignLocation = InStr(s, "@")
    If AtSignLocation = 0 Then
        ExtractEmailAddress = "" 'not found
    Else
        TempStr = ""
        'Get 1st half of email address
        For i = AtSignLocation - 1 To 1 Step -1
            If Mid(s, i, 1) Like CharList Then
                TempStr = Mid(s, i, 1) & TempStr
            Else
                Exit For
            End If
        Next i
        If TempStr = "" Then Exit Function
        'get 2nd half
        TempStr = TempStr & "@"
        For i = AtSignLocation + 1 To Len(s)
            If Mid(s, i, 1) Like CharList Then
                TempStr = TempStr & Mid(s, i, 1)
            Else
                Exit For
            End If
        Next i
    End If
    'Remove trailing period if it exists
    If Right(TempStr, 1) = "." Then TempStr = _
       Left(TempStr, Len(TempStr) - 1)
    ExtractEmailAddress = TempStr
End Function

Quantifying Color Choices

Category: Formatting / VBA Functions | [Item URL]

A companion file is available: Click here to download

I got lots of Excel workbooks via email. A significant number of them have some downright ugly color choices. Beauty is in the eye of the beholder, but there's no excuse for making color choices that result in illegible text.

The World Wide Web Consortium (W3C) has created some formulas that can help you determine if your foreground and background colors are legible: Ensure that foreground and background color combinations provide sufficient contrast when viewed by someone having color deficits or when viewed on a black and white screen.

The W3C presents two formulas, each of which returns a value:

• Color Brightness Difference: returns a value between 0 and 255
• Color Difference: Returns a value between 0 and 765

I converted their formulas into VBA functions, and formulas that use these functions are shown in Columns B and C:

To be an acceptable color combination, the Color Difference score should be 500 or greater, and the Brightness Difference score should be 125 or greater. I used conditional formatting to highlight values that exceed these minimums.

Column D has a simple formula that determines if both score meet the minimum requirement.

These formulas seem to work quite well. The color combination deemed Acceptable are all very legible. Bottom line: You can't go wrong with black text on a white background. Reserve the fancy colors for column headers, or for special areas of a worksheet that you want to be noticed.

Determining The User’s Video Resolution

Category: VBA Functions | [Item URL]

How you can determine the current video resolution? There are two ways that I'm aware of:

1. Maximize Excel's window and then access the Application's Width and Height properties
2. Use a Windows API function

This document presents VBA code to demonstrate both of these techniques.

Getting Excel's window size

The VBA subroutine below maximizes Excel's window, and then displays the width and height.

Sub ShowAppSize()
'   Maximize the window
    Application.WindowState = xlMaximized

'   Get the dimensions
    appWidth = Application.Width
    appHeight = Application.Height

'   Show a message box
    Msg = "Excel's window size is: "

    Msg = Msg & appWidth & " X " & appHeight
    MsgBox Msg
End Sub

This subroutine is quite straightforward, and works with Excel 5 or later versions. The disadvantage is that Excel's metric system does not correspond to pixels. For example, when the video resolution is 1024 X 768 pixels, the preceding subroutine reports that the maximized window size is 774 X 582.

Using the GetSystemMetrics API function

The subroutine below demonstrates how to use a Windows API function to determine the current video resolution. The result is expressed in pixels.

' API declaration
 Declare Function GetSystemMetrics32 Lib "user32" _
    Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

 Public Const SM_CXSCREEN = 0
 Public Const SM_CYSCREEN = 1

Sub DisplayVideoInfo()
    vidWidth = GetSystemMetrics32(SM_CXSCREEN)
    vidHeight = GetSystemMetrics32(SM_CYSCREEN)
    Msg = "The current video mode is: "
    Msg = Msg & vidWidth & " X " & vidHeight
    MsgBox Msg
End Sub

Identifying Unique Values In An Array Or Range

Category: VBA Functions | [Item URL]

Have you ever had to work with just the unique items in a range? If your data is in the form of a database, you can use the Advanced Filter command to extract the unique items from a single column. But if your data spans multiple columns, Advanced Filter won't work. And the Advanced Filter won't do you any good if your data is in a VBA array.

In this document I present a VBA function that accepts either a worksheet range object or a VBA array. The function returns either:

• A variant array that consists of just the unique elements in the input array or range (or)
• A single value: the number of unique elements in the input array or range.

Here's the syntax for the UniqueItems function (which is listed at the end of this document):

 UniqueItems(ArrayIn, Count)

• ArrayIn: A range object, or an array
• Count: (Optional) If True or omitted, the function returns a single value - the number of unique items in ArrayIn. If False, the function returns an array that consists of the unique items in ArrayIn.

Example 1

The subroutine below demonstrates UniqueItems. The routine generates 100 random integers and stores them in an array. This array is then passed to the UniqueItems function and a message box displays the number of unique integers in the array. The number will vary each time you run the subroutine.

Sub Test1()
    Dim z(1 To 100)
    For i = 1 To 100
        z(i) = Int(Rnd() * 100)
    Next i
    MsgBox UniqueItems(z, True)
End Sub

Example 2

The subroutine below counts the number of common elements in two worksheet ranges. It creates two arrays. Array1 consists of the unique items in A1:A16; Array2 consists of the unique items in B1:B16. A nested loop counts the number of items that are in both ranges.

Sub Test2()
    Set Range1 = Sheets("Sheet1").Range("A1:A16")
    Set Range2 = Sheets("Sheet1").Range("B1:B16")
    Array1 = UniqueItems(Range1, False)
    Array2 = UniqueItems(Range2, False)
    CommonCount = 0
    For i = LBound(Array1) To UBound(Array1)
        For j = LBound(Array2) To UBound(Array2)
            If Array1(i) = Array2(j) Then _
              CommonCount = CommonCount + 1
        Next j
    Next i
    MsgBox CommonCount
End Sub

Example 3

The UniqueItems function can also be used in worksheet formulas. The formula below returns the number of unique items in a range:

  =UniqueItems(A1:D21)

Example 4

To display the unique items in a range, you must array-enter the formula into a range of cells (use Ctrl+Shift+Enter). The result of the UniqueItems function is a horizontal array. If you would like to display the unique values in a column, you can use the TRANSPOSE function. The formula below (which is array-entered into a vertical range) returns the unique items in A1:D21.

  =TRANSPOSE(UniqueItems(A1:D21,FALSE))

The Code

Option Base 1

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
'   Accepts an array or range as input
'   If Count = True or is missing, the function returns the number of unique elements
'   If Count = False, the function returns a variant array of unique elements
    Dim Unique() As Variant ' array that holds the unique items
    Dim Element As Variant
    Dim i As Integer
    Dim FoundMatch As Boolean
'   If 2nd argument is missing, assign default value
    If IsMissing(Count) Then Count = True
'   Counter for number of unique elements
    NumUnique = 0
'   Loop thru the input array
    For Each Element In ArrayIn
        FoundMatch = False
'       Has item been added yet?
        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For '(exit loop)
            End If
        Next i
AddItem:
'       If not in list, add the item to unique list
        If Not FoundMatch And Not IsEmpty(Element) Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element
'   Assign a value to the function
    If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function

(Thanks to Peter Atherton for suggesting the method to avoid converting blanks to zero values)

Getting A List Of File Names Using VBA

Category: VBA Functions | [Item URL]

If your macro needs to present a list of files for the user to choose from, the easiest approach is to use the GetOpenFileName method of the Application object. For example, the code below displays the standard File Open dialog box. If the user selects a file, the filename is stored in SelectedFile; if the user clicks Cancel, SelectedFile is equal to False.

 Filter = "Excel files (*.xls), *.xls"
 Caption = "Select a File"
 SelectedFile = Application.GetOpenFilename(Filter, , Caption)

In some cases, however, you may want to get a list of all files in a particular directory. The VBA function below (GetFileList) accepts a DOS path and filespec as its argument, and returns a variant array that contains all of the filenames in that directory. If no matching files are found, the function returns False.

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

The subroutine listed below demonstrates how to use this function. In this example, the filespec is passed to the GetFileList function and the result is stored in x. If x is an array, it means that matching files were found. A message box displays the number of files and the filenames are copied to column A in Sheet1. If x is not an array, it means that no matching files were found.

Sub test()
    Dim p As String, x As Variant

    p = "c:/msoffice/excel/library/*.xls"
    x = GetFileList(p)
    Select Case IsArray(x)
        Case True 'files found
            MsgBox UBound(x)
            Sheets("Sheet1").Range("A:A").Clear
            For i = LBound(x) To UBound(x)
                Sheets("Sheet1").Cells(i, 1).Value = x(i)
            Next i
        Case False 'no files found
            MsgBox "No matching files"
    End Select
End Sub

Looping Through Ranges Efficiently In Custom Worksheet Functions

Category: VBA Functions | [Item URL]

If you create custom worksheet functions using VBA, this tip describes how to write efficient looping code.

Consider the following custom worksheet function.

Function CountBetween(InRange, Lower, Upper)
    TheCount = 0
    For Each Cell In InRange
        If Cell.Value >= Lower And Cell.Value <= Upper _
          Then TheCount = TheCount + 1
    Next Cell
    CountBetween = TheCount
End Function

This function returns the number of cells in a range that fall between two values. The first argument is a range, the second argument is the lower comparison value, and the third argument is the upper comparison value. If you wanted to count the number of values between 1 and 5 in the range A1:A20, you could use this formula:

  =CountBetween(A1:A20,1,5)

This function works fine in most situations. However, try entering the following formula and see what happens:

  =CountBetween(A:A,1,5)

You'll find that evaluating this function seems to take forever since it will loop through all cells in the range -- even those that are beyond the worksheet's "used range."

My original approach to solving this problem was to use the SpecialCells method to create a subset of the input range that consisted only of nonempty cells. However, I discovered that SpecialCells is off-limits inside of a worksheet function.

I eventually learned the solution. The function below uses the Intersect function to create a new range object that consists of the intersection of the UsedRange and the input range.

Function CountBetween2(InRange, Lower, Upper)
    Set SubSetRange = Intersect(InRange.Parent.UsedRange, InRange)
    TheCount = 0
    For Each Cell In SubSetRange
        If Cell.Value >= Lower And Cell.Value <= Upper Then _
            TheCount = TheCount + 1
    Next Cell
    CountBetween2 = TheCount
End Function

The addition of the Set statement solves the problem. You'll find that this function works equally fast with either of these formulas:

  =CountBetween(A1:A20,1,5)
  =CountBetween(A:A,1,5)

This technique can be adapted to any custom worksheet function that accepts a range argument and loops through each cell in the range.

Undoing A VBA Subroutine

Category: VBA Functions | [Item URL]

Computer users are accustomed to the ability to "undo" an operation. Almost every operation you perform in Excel can be undone. If you program in VBA, you may have wondered if it's possible to undo the effects of a subroutine. The answer is yes. The qualified answer is it's not always easy.

Making the effects of your subroutines undoable isn't automatic. Your subroutine will need to store the previous state so it can be restored if the user choose the Edit Undo command. How you do this will vary, depending on what the subroutine does. In extreme cases, you might need to save an entire worksheet. If your subroutine modifies a range, for example, you need only save the contents of that range.

The code below demonstrates how to enable the Edit Undo command after a subroutine is executed. The subroutine itself is very simple: it simply inserts a 0 into every cell in the current range selection. The bulk of the code is used to save the contents of the current selection.

Trying it out

To try out this example code:

1. Copy the code to an empty VBA module.
2. Enter some data into a worksheet range.
3. Select the range and execute the ZeroRange subroutine. The cells will be replaced with zeros.
4. Select the Edit Undo command. The original contents of the selection will be restored.

How it works

The OldSelection array stores the cell address and the cell contents (using a custom data type). Notice that this array is declared as a Public variable so it's available to all subroutines. The last statement in the ZeroRange subroutine specifies the text to display in the Undo menu, and the subroutine to call if this command is selected. The UndoZero routine loops through the OldSelection array and restores the values to their appropriate cells. Notice that I also store the workbook and worksheet -- which ensures that the correct cells will be restored even if the user switches out of the original worksheet.

The Undo example

'Custom data type for undoing
    Type SaveRange
        Val As Variant
        Addr As String
    End Type
    
'   Stores info about current selection
    Public OldWorkbook As Workbook
    Public OldSheet As Worksheet
    Public OldSelection() As SaveRange


Sub ZeroRange()
'   Inserts zero into all selected cells

'   Abort if a range isn't selected
    If TypeName(Selection) <> "Range" Then Exit Sub

'   The next block of statements
'   Save the current values for undoing
    ReDim OldSelection(Selection.Count)
    Set OldWorkbook = ActiveWorkbook
    Set OldSheet = ActiveSheet
    i = 0
    For Each cell In Selection
        i = i + 1
        OldSelection(i).Addr = cell.Address
        OldSelection(i).Val = cell.Formula
    Next cell
            
'   Insert 0 into current selection
    Application.ScreenUpdating = False
    Selection.Value = 0
    
'   Specify the Undo Sub
    Application.OnUndo "Undo the ZeroRange macro", "UndoZero"
End Sub


Sub UndoZero()
'   Undoes the effect of the ZeroRange sub
    
'   Tell user if a problem occurs
    On Error GoTo Problem

    Application.ScreenUpdating = False
    
'   Make sure the correct workbook and sheet are active
    OldWorkbook.Activate
    OldSheet.Activate
    
'   Restore the saved information
    For i = 1 To UBound(OldSelection)
        Range(OldSelection(i).Addr).Formula = OldSelection(i).Val
    Next i
    Exit Sub

'   Error handler
Problem:
    MsgBox "Can't undo"
End Sub

Other examples of Undo

If you've purchased the source code to Power Utility Pak, you can examine these utilities for other, more complex, examples of using undo.

Determining The Last Non-empty Cell In A Column Or Row

Category: VBA Functions | [Item URL]

This tip presents two useful VBA functions that can be used in worksheet formulas. LASTINCOLUMN returns the contents of the last non-empty cell in a column; LASTINROW returns the contents of the last non-empty cell in a row. Each function accepts a range as its single argument. The range argument can be a complete column (for LASTINCOLUMN) or a complete row (for LASTINROW). If the supplied argument is not a complete column or row, the function uses the column or row of the upper left cell in the range. For example, the following formula returns the last value in column B:

=LASTINCOLUMN(B5)

The formula below returns the last value in row 7:

=LASTINROW(C7:D9)

You'll find that these functions are quite fast, since they only examine the cells in the intersection of the specified column (or row) and the worksheet's used range.

The LASTINCOLUMN function

Function LASTINCOLUMN(rngInput As Range)
    Dim WorkRange As Range
    Dim i As Long, CellCount As Long
    Application.Volatile
    Set WorkRange = rngInput.Columns(1).EntireColumn
    Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
    CellCount = WorkRange.Count
    For i = CellCount To 1 Step -1
        If Not IsEmpty(WorkRange(i)) Then
            LASTINCOLUMN = WorkRange(i).Value
            Exit Function
        End If
    Next i
End Function

The LASTINROW function

Function LASTINROW(rngInput As Range) As Variant
    Dim WorkRange As Range
    Dim i As Long, CellCount As Long
    Application.Volatile
    Set WorkRange = rngInput.Rows(1).EntireRow
    Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
    CellCount = WorkRange.Count
    For i = CellCount To 1 Step -1
        If Not IsEmpty(WorkRange(i)) Then
            LASTINROW = WorkRange(i).Value
            Exit Function
        End If
    Next i
End Function

Multifunctional Functions

Category: VBA Functions | [Item URL]

This tip describes a technique that may be helpful in some situations - making a single worksheet function act like multiple functions. For example, the VBA listing below is for a custom function called StatFunction. It takes two arguments: the range (rng), and the operation (op). Depending on the value of op, the function will return any of the following: AVERAGE, COUNT, MAX, MEDIAN, MIN, MODE, STDEV, SUM, or VAR.

For example, you can use this function in your worksheet as follows:

 =STATFUNCTION(B1:B24,A24)

The result of the formula depends on the contents of cell A24 -- which should be a string such as Average, Count, Max, etc. You can adapt this technique for other types of functions.

The StatFunction Function

Function STATFUNCTION(rng, op)
    Select Case UCase(op)
        Case "SUM"
            STATFUNCTION = Application.Sum(rng)
        Case "AVERAGE"
            STATFUNCTION = Application.Average(rng)
        Case "MEDIAN"
            STATFUNCTION = Application.Median(rng)
        Case "MODE"
            STATFUNCTION = Application.Mode(rng)
        Case "COUNT"
            STATFUNCTION = Application.Count(rng)
        Case "MAX"
            STATFUNCTION = Application.Max(rng)
        Case "MIN"
            STATFUNCTION = Application.Min(rng)
        Case "VAR"
            STATFUNCTION = Application.Var(rng)
        Case "STDEV"
            STATFUNCTION = Application.StDev(rng)
        Case Else
            STATFUNCTION = Evaluate("NA()")
    End Select
End Function

Page 1 of 3 pages
[Next page]