Multi-Select Listbox, Output by Order Selected

[gmaxey]

Earlier today I was presented with an interesting challenge and thought I would post the solution here. The user wanted to ensure that the items selected in a userform multi-select listbox where presented in the document in the order selected.

Create simple userform with a listbox named lstItems and command button named cmdOK. Insert this code in the form module. In the document add a bookmark "bmOutput"


Option Explicit
Dim lngIndex As Long
Private colSelected As New Collection

Private Sub UserForm_Initialize()
Dim lngIndex As Long
With lstItems
.AddItem "Central"
.AddItem "Northern"
.AddItem "Southern"
.AddItem "Eastern"
End With
lbl_Exit:
Exit Sub
End Sub

Private Sub lstItems_Change()
Dim lngIndex As Long
Dim lngItem As Long
'Builds a collection of items by order selected.
For lngIndex = 0 To lstItems.ListCount - 1
If lstItems.Selected(lngIndex) Then
On Error Resume Next
colSelected.Add CStr(lngIndex), CStr(lngIndex)
On Error GoTo 0
Else
For lngItem = colSelected.Count To 1 Step -1
If colSelected.Item(lngItem) = CStr(lngIndex) Then
colSelected.Remove (lngItem)
End If
Next lngItem
End If
Next lngIndex
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdOK_Click()
Dim lngItem As Long
Dim strOut As String
Dim lngSelected As Long
strOut = vbNullString
For lngSelected = 1 To colSelected.Count
lngItem = CLng(colSelected.Item(lngSelected))
strOut = strOut & lstItems.List(lngItem, 0) & vbCr
Next lngSelected
WriteToBM "bmOutput", strOut
Hide
lbl_Exit:
Exit Sub
End Sub

Sub WriteToBM(strBMName, strText)
Dim oRng As Range
Set oRng = ActiveDocument.Bookmarks(strBMName).Range
oRng.Text = strText
ActiveDocument.Bookmarks.Add strBMName, oRng
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Based on private feedback to enhance usability, the code above is modified to illustrate the order selected:


Option Explicit
Dim lngIndex As Long
Private colSelected As New Collection

Private Sub UserForm_Initialize()
Dim lngIndex As Long
With lstItems
.ColumnCount = 2
.ColumnWidths = "100;15"
.AddItem "Central"
.AddItem "Northern"
.AddItem "Southern"
.AddItem "Eastern"
End With
lbl_Exit:
Exit Sub
End Sub
Private Sub lstItems_Change()
Dim lngIndex As Long
Dim lngItem As Long
Dim lngCounter As Long
'Builds a collection of items by order selected.
For lngIndex = 0 To lstItems.ListCount - 1
lstItems.List(lngIndex, 1) = vbNullString
If lstItems.Selected(lngIndex) Then
On Error Resume Next
colSelected.Add CStr(lngIndex), CStr(lngIndex)
On Error GoTo 0
Else
For lngItem = colSelected.Count To 1 Step -1
If colSelected.Item(lngItem) = CStr(lngIndex) Then
colSelected.Remove (lngItem)
End If
Next lngItem
End If
Next lngIndex
lngCounter = 1
For lngIndex = 1 To colSelected.Count
lstItems.List(colSelected.Item(lngIndex), 1) = lngCounter
lngCounter = lngCounter + 1
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Private Sub cmdOK_Click()
Dim lngItem As Long
Dim strOut As String
Dim lngSelected As Long
strOut = vbNullString
For lngSelected = 1 To colSelected.Count
lngItem = CLng(colSelected.Item(lngSelected))
strOut = strOut & lstItems.List(lngItem, 0) & vbCr
Next lngSelected
WriteToBM "bmOutput", strOut
Hide
lbl_Exit:
Exit Sub
End Sub
Sub WriteToBM(strBMName, strText)
Dim oRng As Range
Set oRng = ActiveDocument.Bookmarks(strBMName).Range
oRng.Text = strText
ActiveDocument.Bookmarks.Add strBMName, oRng
lbl_Exit:
Exit Sub
End Sub