frmSel
Select Multiple Items
Sometimes we want users to select one or more items from a list, like when we want to filter a table. This form presents any list from which users may filter and select from. When the user clicks OK, it returns what was selected.
In the example at right, I'm giving users a list of Power Query functions and queries to choose from, but this form could just as easily present a list of worksheets, tables, charts, employees, accounts, regions, etc. In the code example below, I'm calling the form to display a list of worksheets in the active workbook.
?frmSel.Display(Title:="Worksheets", _
List:=ActiveWorkbook.Sheets)
If the user selects Sheet1 and Sheet2, the form will return their names in a comma separated value string (CSV) like this: Sheet1,Sheet2.
frmSel handles multi-column lists as well, which means we can pass an entire table range as the list. But only the first column can be filtered or returned.
NOTE! This uses several functions from my general purpose library: modGeneral. See bottom for links to those functions.
Creating frmSel
This userform mimics the table filter button's selection dialog. To accomplish this, frmSel requires just a few components. They include:
txtFilter - TextBox where users can enter a few characters and frmSel will select all items in the list that contain those characters
cmdClear - CommandButton users can click to clear txtFilter and deselect items in the list.
lstList - ListBox where Items are displayed with the first item being "Select All" to select or deselect all items.
lblHidden - Label with its AutoSize property set to TRUE. and Visible property set to FALSE. We use this to determine lstList's column sizes.
cmdOK - CommandButton that when clicked instructs this from to return all selected items in a CSV.
cmdCancel - CommandButton that when clicked returns a null string (vbNullString)
Placement of these items is handled by the form itself so it can accommodate lists of varying width and column numbers.
Coding frmSel: Module Level Code
After creating the userform's visual components, display its code and enter this module level code which contains some documentation and variables that will be accessible by all routines in this form.
Of special not is the declaration of API GetAsyncKeyState. This is used to determine if the shift key is pressed while selecting which causes a selection-from-here-to-there event.
' Version: 12/27/21
' Save as: frmSel
' Description:Simple Multi-Select
' Date Ini Modification
' 12/27/21 CWH Initial Development
Option Explicit
Option Compare Text
' Private Properties
Private Const cModule As String = "frmSel" 'This module's name
Private bOK As Boolean 'OK button pressed
#If VBA7 Then
' Get Key state
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As LongPtr) As Integer
#Else
' Get Key state
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Coding frmSel: Initialize and Terminate
This procedure runs when we instantiate the form. I prefer my forms be formatted and so the first two lines connect this form to clsForm (see References at bottom). If you are okay with Excel's gray format, delete those two lines.
Private Sub UserForm_Initialize()
' NOTE! Static - to keep in memory after this routine ends
Static FormClass As New clsForm
Set FormClass.UserForm = Me
bCancelled = False
End Sub
This procedure runs if the user clicks the red X in the upper right corner. This handles that event as if the user clicked cancel.
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' If "X" clicked, cancel unloading. Use cmdCancel_Click instead
If CloseMode = vbFormControlMenu Then
Cancel = True
cmdCancel_Click
End If
End Sub
Coding frmSel: Event Handlers
These procedures respond to events such as mouse clicks or changes to controls. Procedures are listed in order of their associated control's appearance.
This procedure selects all items in the list that contain whatever the end user types into txtFilter
Private Sub txtFilter_Change()
' Description:Select items in lstList containing this control's characters
' Date Ini Modification
' 12/27/21 CWH Initial Programming
' Declarations
Const cRoutine As String = "txtFilter_Change"
Dim bEvents As Boolean 'Prevent this from triggering itself
Dim n As Long 'Loop Counter
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
bEvents = Application.EnableEvents
If bEvents Then
Application.EnableEvents = False
With Me.lstList
For n=1 To .ListCount -1 'Skip "Select All" in 0
.Selected(n) = .List(n, 0) Like "*" & txtFilter.Value & "*"
Next
End With
End If
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
' Clean up
Application.EnableEvents = bEvents
End Sub
This procedure clears txtFilter and deselects all items in the list.
Private Sub CmdClear_Click()
' Description:Handel Clear click
' Date Ini Modification
' 12/27/21 CWH Initial Programming
' Declarations
Const cRoutine As String = "CmdClear_Click"
Dim bEvents As Boolean 'Prevent this from triggering itself
Dim n As Long 'Loop Counter
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
bEvents = Application.EnableEvents
If bEvents Then
Application.EnableEvents = False
With Me.lstList
For n=1 To .ListCount -1 'Skip "Select All" in 0
.Selected(n) = False
Next
End With
End If
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
' Clean up
Application.EnableEvents = bEvents
End Sub
This procedure handles changes (selections) to the list.
Private Sub lstList_Change()
' Description:Handle Selection events
' Requisites: API GetAsyncKeyState
' Date Ini Modification
' 12/27/21 CWH Initial Programming
' Declarations
Const cRoutine As String = "lstList_Change"
Static lLastIndex As Long 'Last selected item
Dim bEvents As Boolean 'Prevent this from triggering itself
Dim lStep As Long 'Loop Step
Dim n As Long 'Loop Counter
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
bEvents = Application.EnableEvents
If bEvents Then
Application.EnableEvents = False
With Me.lstList
' Handle Select All
If .ListIndex = 0 Then
If .List(0,0) = "Select All" Then
For n=1 To .ListCount -1 'Skip "Select All" in 0
.Selected(n) = .Selected(0)
Next
End If
' Handle Shift Key when something is selected
ElseIf .Selected(.ListIndex) Then
If .ListIndex > 0 Then
If GetAsyncKeyState(&H10) <> 0 Then 'Shift Key
lStep = IIF(.ListIndex < lLastIndex, 1, -1)
For n = .ListIndex To lLastIndex Step lStep
.Selected(n) = True
Next
End If
End If
lLastIndex = .ListIndex
Else
lLastIndex = 0
End If
End With
End If
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
' Clean up
Application.EnableEvents = bEvents
End Sub
These procedures handle clicks on OK and Cancel buttons
Private Sub cmdOK_Click(): bOK = True: Me.Hide: End Sub
Private Sub cmdCancel_Click(): bOK = False: Me.Hide: End Sub
Coding frmSel: Public Methods
This procedure provides the callable interface to other routines. It loads the list into the form and, if provided in Options, adds radio control option buttons to the form. Here is an example of how to call this routine to display options from which the user may select just one.
?frmSel.Display(Title:="Worksheets", List:=[tblEmloyees], Options:="Add,Delete,Change")
This will add three radio buttons to the form. The radio buttons will be opt0, opt1, and opt2. opt0 will have the label "Add" and we can determine the state of the radio buttons in our calling routinge like so:
If frmSel.opt0 then 'add an employee
After loading the list, adding radio buttons, and arranging the controls, Display() show the form until the user clicks cmdOK or cmdCancel. If cmdOK clicked, then this returns a CSV of selected items.
Public Function Display(ByVal Title As String, _
ByVal List As Variant, _
Optional ByVal Options As String = vbNullString) As String
' Description:Select Multiple items from a small list
' Inputs: Title Text for the form's title
' List Range,Table,Collection, or CSV with allowed values
' Options CSV of text for optional radio buttons
' Outputs: OK Click CSV of values
' Exit Clicked vbNullString
' Requisites: Routines SetCtrls
' Example: ?frmSelQry.Display("Select Queries", activeworkbook.Queries)
' Date Ini Modification
' 12/27/21 CWH Initial Development
' Declarations
Const cRoutine As String = "Display"
Dim sCSV As String 'Comma separated list of selected values
Dim n As Long 'Loop Counter
' Error Handling and Function initialization
On Error GoTo ErrHandler
' Initialize Variables
sCSV = vbNullString
Caption = Title
Fill Me.lstList, List
SetCtrls Options
' Procdure
Show vbModeless
While Visible: DoEvents: Wend
If bOk Then
For n = 1 To lstList.ListCount - 1 'Skip "Select All"
If lstList.Selected(n) Then
sCSV = sCSV & _
IIf(Len(sCSV) > 0, ",", "") & _
Trim(lstList.List(n, 0))
End If
Next n
End If
Display = sCSV
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Coding frmSel: Private Functions
These functions are only accessible by this form.
The first procedure loads the form's listbox with items passed in the Display() List parameter. This routine accepts lists in various forms. They can CSVs, Ranges, Tables, Arrays, or object collections.
Private Function Fill(ByRef oList As Object, _
ByVal vList As Variant) As Boolean
' Description:Fill ListBox
' Inputs: oList ListBox to Fill
' vList Values for List
' Outputs: Me Success/Failure
' Requisites: Routines modGeneral.Collection2CSV
' modGeneral.ArrayDimensions
' Example: Fill me, "True,False"
' Date Ini Modification
' 12/27/21 CWH Initial Development
' Declarations
Const cRoutine As String = "Display"
Dim vArray As Variant 'Array to hold list values
Dim lColWid As Long 'Current Column's width (in Characters)
Dim lRowWid As Long 'Current Row's Width (In Characters)
Dim lMaxWid As Long 'Maxium Row Width
Dim lRow As Long 'Array Row
Dim lCol As Long 'Array Column (if any)
Dim sCols() As String 'Column Widths Array as String for List Object
Dim lCols() As Long 'Column Widths Array
Dim lDim As Long 'Array Dimensions
Dim lBnd As Long 'Array lBound
' Error Handling and Function initialization
On Error GoTo ErrHandler
' Procedure
' Create Array
Select Case TypeName(vList)
Case Is = "Range", "Variant()": vArray = vList
Case Is = "ListObject": vArray = vList.DataBodyRange
Case Is = "String": vArray = Split(vList, ",")
Case Else: vArray = Split(Collection2CSV(vList), ",")
End Select
lDim = modGeneral.ArrayDimensions(vArray)
lBnd = LBound(vArray)
If lDim > 1 Then
ReDim lCols(LBound(vArray, 2) To UBound(vArray, 2))
ReDim sCols(LBound(vArray, 2) To UBound(vArray, 2))
End If
' Array to ListBox
With oList
.Clear
' Set column Count
If lDim = 1 Then _
.ColumnCount = 1 Else _
.ColumnCount = 1 + UBound(vArray, 2) - lBnd
' Fill List
.AddItem
.List(0, 0) = "Select All"
For lRow = LBound(vArray) To UBound(vArray)
.AddItem
If lDim = 1 Then
.List(lRow - lBnd + 1, 0) = vArray(lRow)
lRowWid = Len(vArray(lRow))
If lRowWid > lMaxWid Then lMaxWid = lRowWid
Else
lRowWid = 0
For lCol = LBound(vArray, 2) To UBound(vArray, 2)
' Make enough room for "Select All" in first column
If lCol = LBound(vArray, 2) Then _
lblHidden.Caption = "Select All" Else _
lblHidden.Caption = vArray(lRow, lCol)
' Set column widths
DoEvents
lColWid = Application.Max(25, Int(1 + lblHidden.Width), lCols(lCol))
lColWid = lColWid * 1.03
sCols(lCol) = CStr(lColWid)
lCols(lCol) = lColWid
' Add value to Listbox
.List(lRow - lBnd + 1, lCol - lBnd) = vArray(lRow, lCol)
lRowWid = lRowWid + lCols(lCol)
Next
If lRowWid > lMaxWid Then lMaxWid = lRowWid
End If
Next
End With
If lDim > 1 Then oList.ColumnWidths = Join(sCols, ";")
Me.lstList.Width = lMaxWid
Fill = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
This next procedure positions controls on the form.
Private Function SetCtrls(ByVal sOptions As String) As Boolean
' Description:Set Controls
' Inputs: sOptions Text for optional radio buttons
' Outputs: Me Success/Failure
' Requisites: Routines modGeneral.Exists
' Example: See Display
' Date Ini Modification
' 12/12/21 CWH Initial Development
' Declarations
Const cRoutine As String = "SetCtrls"
Dim oCtrl As Control 'Added form control
Dim vOptions As Variant 'Optional radio buttons array
Dim n As Long 'Loop Counter
Dim lBottom As Long 'List Bottom + Space
Dim lLeft As Long 'List Left
' Error Handling and Function initialization
On Error GoTo ErrHandler
SetCtrls = Failure 'Assume the worst
' Procedure
lBottom = Me.lstList.Top + Me.lstList.Height + 5
lLeft = Me.lstList.Left
' Add options (if any)
If sOptions <> vbNullString Then
vOptions = Split(sOptions, ",")
For n = LBound(vOptions) To UBound(vOptions)
If Not Exists(Me.Controls, "opt" & n, oCtrl) Then _
Set oCtrl = Me.Controls.Add("Forms.OptionButton.1", "opt" & n)
oCtrl.Caption = vOptions(n)
oCtrl.Left = lLeft
oCtrl.Top = lBottom + n * 16
Next
Me.Controls("opt0").Value = True
lBottom = lBottom + n * 16 + 4
End If
' Position controls
With Me.lstList
.Width = Application.Max(200, .Width)
.Width = Application.Min(Application.Width / 2, .Width)
DoEvents
Me.txtFilter.Width = .Width - Me.cmdClear.Width
Me.cmdClear.Left = .Left + .Width - cmdClear.Width
Me.cmdCancel.Left = .Left + .Width - Me.cmdCancel.Width
Me.cmdCancel.Top = lBottom
Me.cmdOK.Left = cmdCancel.Left - Me.cmdOK.Width - 5
Me.cmdOK.Top = lBottom
Me.lblMsg.Left = .Left
Me.lblMsg.Width = .Width
Me.lblMsg.Top = cmdOK.Top + cmdOK.Height + 5
Me.Width = 2 * (Me.Width - Me.InsideWidth) + .Width
Me.Height = Me.Height - Me.InsideHeight + Me.lblMsg.Top + Me.lblMsg.Height + 5
End With
SetCtrls = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function