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


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.



Page 7 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 200 useful tips and tricks for Excel 2007 | Other Excel 2007 books | Amazon link: John Walkenbach's Favorite Excel 2007 Tips & Tricks

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

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