Identifying Unique Values In An Array Or Range
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):
- 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.
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
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
The UniqueItems function can also be used in worksheet formulas. The formula below returns the number of unique items in a range:
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.
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
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
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:
This function works fine in most situations. However, try entering the following formula and see what happens:
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:
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
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:
- Copy the code to an empty VBA module.
- Enter some data into a worksheet range.
- Select the range and execute the ZeroRange subroutine. The cells will be replaced with zeros.
- 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
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:
The formula below returns the last value in row 7:
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
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:
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
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
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.
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
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:
A Custom Function For Relative Sheet References
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:
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:
- 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.
Search for Tips
Browse Tips by Category
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