Option Explicit
Dim oTeamMembers As Range
Dim otxtTeam As Range
Private Const Team_A As String = "Dave,Rob,Sarah,Dave,Rob,Sarah,Liz,Mike"
Private Const Team_B As String = "Mike,June,Mary,John,Steve,Maria,Liz,Andy"
Private Const Team_C As String = "Steve,John,Mary,Ivan,Dan,Lisa,Ian,Joan"
Private Sub UserForm_Initialize()
With Teams
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
TeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True
End Sub
Private Sub Teams_Change()
Dim lngIndex As Long
Dim lngSelected As Long
TeamMembers.Clear
For lngSelected = 0 To Teams.ListCount - 1
If Teams.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
TeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
TeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
TeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub
Private Sub TeamMembers_Change()
Dim lngIndex As Long, lngCount As Long
Dim arrTMs() As String
lngCount = 0
For lngIndex = 0 To TeamMembers.ListCount - 1
If TeamMembers.Selected(lngIndex) Then
ReDim Preserve arrTMs(lngCount)
lngCount = lngCount + 1
arrTMs(UBound(arrTMs)) = TeamMembers.List(lngIndex)
End If
Next lngIndex
If IsArray(arrTMs) Then txtTeam = fcnArrayToCommaAndDelimtedList(arrTMs)
End Sub
'**** Create a comma/and delimited list
Public Function fcnArrayToCommaAndDelimtedList(varIn As Variant, Optional bOxford As Boolean = False) As String
Dim strTemp As String
Dim lngIndex As Long
On Error GoTo lbl_Exit
Select Case UBound(varIn)
Case 0: fcnArrayToCommaAndDelimtedList = varIn(0)
Case 1: fcnArrayToCommaAndDelimtedList = varIn(0) & " and " & varIn(1)
Case Else
fcnArrayToCommaAndDelimtedList = varIn(0)
lngIndex = 1
Do While lngIndex < UBound(varIn)
fcnArrayToCommaAndDelimtedList = fcnArrayToCommaAndDelimtedList & ", " & varIn(lngIndex)
lngIndex = lngIndex + 1
Loop
If bOxford Then
fcnArrayToCommaAndDelimtedList = fcnArrayToCommaAndDelimtedList & ", and " & varIn(lngIndex)
Else
fcnArrayToCommaAndDelimtedList = fcnArrayToCommaAndDelimtedList & " and " & varIn(lngIndex)
End If
End Select
lbl_Exit:
Exit Function
End Function
'Enter button
Private Sub EnterBut_Click()
'Check required fields are filled out
If txtTeam.Text = "" Then
MsgBox "Provide list of team members", vbCritical, "Triage Hub"
txtTeam.SetFocus
Exit Sub
End If
'use FillBM function to write bookmarks
FillBM "TeamMembers", txtTeam.Text
Set oTeamMembers = Nothing
Set otxtTeam = Nothing
Unload Me
Exit Sub
End Sub
Private Sub FillBM(strbmName As String, strValue As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
If .Bookmarks.Exists(strbmName) = True Then
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strbmName
End If
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub