Selecting a team from a ListBox

[HTSCF Fareha]

I have a simple form that allows for the selection of team members to be assigned to a work task.

My form has a ComboBox which allows for selection of either Team 1, Team 2 or Team 3.

Depending on the selection, I then have a ListBox with members associated with the team selected. The form user will then select multiple names from this ListBox, to be transferred to a TextBox prior to the ‘Enter’ button being pressed to fill in the names at the correct place in the form via a Bookmark. The reason for the need for the TextBox to be populated prior to the enter button is to allow for the form user to manually add names that are not members of any of the three teams.

My form at the moment only works as far as allowing for a selection from the ComboBox. Not a very good start really!

Help would be very much appreciated, thanks.


Option Explicit

Private Sub EnterBut_Click()
Dim oTeamMembers As Range

'Check if a team has been selected
If ComboBox1.ListIndex = 0 Then
MsgBox "Select Team", vbCritical, "Triage Hub"
ComboBox1.SetFocus
Exit Sub
End If

'Check if team members have been selected
If TextBox1.Text = "" Then
MsgBox "Select Team Members", vbCritical, "Triage Hub"
TextBox1.SetFocus
Exit Sub
End If

'use FillBM function to write bookmarks
FillBM "TeamMembers", TextBox1.Text

Set oTeamMembers = Nothing
Unload Me
lbl_Exit
Exit Sub

End Sub

Private Sub UserForm_Initialize()
Dim myArray() As String

'Create list of teams
myArray = Split("Select Team|Team 1|Team 2|Team 3", "|")

'Use List method to populate ComboBox
ComboBox1.List = myArray
ComboBox1.ListIndex = 0

'Redefine list for team members Team 1
myArray = Split("Select Team Members Team 1|Dave|Rob|Sarah|Dave|Rob|Sarah|Liz|Mike", "|")

'Redefine list for team members Team 2
myArray = Split("Select Team Members Team 2|Mike|June|Mary|John|Steve|Maria|Liz|Andy", "|")

'Redefine list for team members Team 3
myArray = Split("Select Team Members Team 3|Steve|John|Mary|Ivan|Dan|Lisa|Ian|Joan", "|")

lbl_Exit:
Exit Sub
End Sub

Private Sub ListBox1_Change()
If ListBox1.ListIndex > 0 Then
TextBox1.Text = ListBox1.Value
End If

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

[gmaxey]

Not very elegant, but should work:

Option Explicit
Dim myArray() As String

Private Sub ComboBox1_Change()
Select Case ComboBox1.ListIndex
Case 0
ListBox1.Clear

Case 1
'Redefine list for team members Team 1
myArray = Split("Select Team Members Team 1|Dave|Rob|Sarah|Dave|Rob|Sarah|Liz|Mike", "|")
ListBox1.List = myArray
Case 2
'Redefine list for team members Team 2
myArray = Split("Select Team Members Team 2|Mike|June|Mary|John|Steve|Maria|Liz|Andy", "|")
ListBox1.List = myArray


Case 3
'Redefine list for team members Team 3
myArray = Split("Select Team Members Team 3|Steve|John|Mary|Ivan|Dan|Lisa|Ian|Joan", "|")
ListBox1.List = myArray

End Select


End Sub

Private Sub UserForm_Initialize()

'Create list of teams
myArray = Split("Select Team|Team 1|Team 2|Team 3", "|")
'Use List method to populate ComboBox
ComboBox1.List = myArray
ComboBox1.ListIndex = 0
ListBox1.MultiSelect = fmMultiSelectMulti

lbl_Exit:
Exit Sub
End Sub

Private Sub ListBox1_Change()
Dim lngIndex As Long, lngCOunt As Long
Dim arrTMs() As String
lngCOunt = 0
For lngIndex = 1 To ListBox1.ListCount - 1
If ListBox1.Selected(lngIndex) Then
ReDim Preserve arrTMs(lngCOunt)
lngCOunt = lngCOunt + 1
arrTMs(UBound(arrTMs)) = ListBox1.List(lngIndex)
End If
Next lngIndex
If IsArray(arrTMs) Then TextBox1 = 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

[HTSCF Fareha]

Thanks for taking a look at this, Greg. Unfortunately this doesn't work. There are no errors, just a blank ComboBox1 for starters.


Option Explicit

Private Sub EnterBut_Click()
Dim oTeamMembers As Range

'Check if a team has been selected
If ComboBox1.ListIndex = 0 Then
MsgBox "Select Team", vbCritical, "Triage Hub"
ComboBox1.SetFocus
Exit Sub
End If

'Check if team members have been selected
If TextBox1.Text = "" Then
MsgBox "Select Team Members", vbCritical, "Triage Hub"
TextBox1.SetFocus
Exit Sub
End If

'use FillBM function to write bookmarks
FillBM "TeamMembers", TextBox1.Text

Set oTeamMembers = Nothing
Unload Me
lbl_Exit
Exit Sub

End Sub

Option Explicit
Dim myArray() As String

Private Sub ComboBox1_Change()
Select Case ComboBox1.ListIndex
Case 0
ListBox1.Clear

Case 1
'Redefine list for team members Team 1
myArray = Split("Select Team Members Team 1|Dave|Rob|Sarah|Dave|Rob|Sarah|Liz|Mike", "|")
ListBox1.List = myArray
Case 2
'Redefine list for team members Team 2
myArray = Split("Select Team Members Team 2|Mike|June|Mary|John|Steve|Maria|Liz|Andy", "|")
ListBox1.List = myArray

Case 3
'Redefine list for team members Team 3
myArray = Split("Select Team Members Team 3|Steve|John|Mary|Ivan|Dan|Lisa|Ian|Joan", "|")
ListBox1.List = myArray

End Select

End Sub

Private Sub ListBox1_Change()
Dim lngIndex As Long, lngCOunt As Long
Dim arrTMs() As String
lngCOunt = 0
For lngIndex = 1 To ListBox1.ListCount - 1
If ListBox1.Selected(lngIndex) Then
ReDim Preserve arrTMs(lngCOunt)
lngCOunt = lngCOunt + 1
arrTMs(UBound(arrTMs)) = ListBox1.List(lngIndex)
End If
Next lngIndex
If IsArray(arrTMs) Then TextBox1 = 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

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

[gmaxey]

Your code would not even compile. You have two Option Explicit statements and you have no code to populate the combobox.

[HTSCF Fareha]

I'm embarassed that I had two Option Explicit statements. I'm learning but have been told this before :doh:.

I've added a ComboBox to list the three teams, although now I have a 'Variable not defined' here:-



Private Sub ComboBox1_Change()

I'm sure I'm doing something silly to get this error.


Option Explicit

Private Sub EnterBut_Click()
Dim oTeamMembers As Range

'Check if a team has been selected
If ComboBox1.ListIndex = 0 Then
MsgBox "Select Team", vbCritical, "Triage Hub"
ComboBox1.SetFocus
Exit Sub
End If

'Check if team members have been selected
If TextBox1.Text = "" Then
MsgBox "Select Team Members", vbCritical, "Triage Hub"
TextBox1.SetFocus
Exit Sub
End If

'use FillBM function to write bookmarks
FillBM "TeamMembers", TextBox1.Text

Set oTeamMembers = Nothing
Unload Me
lbl_Exit
Exit Sub

End Sub

Private Sub ComboBox1_Change()
Select Case ComboBox1.ListIndex
Case 0
ListBox1.Clear

Case 1
'Redefine list for team members Team 1
myArray = Split("Select Team Members Team 1|Dave|Rob|Sarah|Dave|Rob|Sarah|Liz|Mike", "|")
ListBox1.List = myArray
Case 2
'Redefine list for team members Team 2
myArray = Split("Select Team Members Team 2|Mike|June|Mary|John|Steve|Maria|Liz|Andy", "|")
ListBox1.List = myArray

Case 3
'Redefine list for team members Team 3
myArray = Split("Select Team Members Team 3|Steve|John|Mary|Ivan|Dan|Lisa|Ian|Joan", "|")
ListBox1.List = myArray

End Select

End Sub

Private Sub ListBox1_Change()
Dim lngIndex As Long, lngCOunt As Long
Dim arrTMs() As String
lngCOunt = 0
For lngIndex = 1 To ListBox1.ListCount - 1
If ListBox1.Selected(lngIndex) Then
ReDim Preserve arrTMs(lngCOunt)
lngCOunt = lngCOunt + 1
arrTMs(UBound(arrTMs)) = ListBox1.List(lngIndex)
End If
Next lngIndex
If IsArray(arrTMs) Then TextBox1 = 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

Private Sub UserForm_Initialize()
Dim myArray() As String
'Create list of teams
myArray = Split("- Select -|Team 1|Team 2|Team 3", "|")
'Use List method to populate ComboBox
ComboBox1.List = myArray
ComboBox1.ListIndex = 0
lbl_Exit:
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

[gmaxey]

You might try declaring your myArray variable at the module level like I showed you in my first reply. When you use the Option Explicit statement (once), you "MUST" declare variables.

Option Explicit
Dim myArray() As String

[HTSCF Fareha]

Okay, I've put the variables at the top.

The ComboBox allows the selection of Team 1, Team 2 or Team 3, which populates the ListBox with the correct names for the respective team. But it will only allow for the selection of one of the names (which is transferred to the TextBox), rather than multiple selection.

Pressing the 'Enter' button also gives a compile error - sub or function not defined here:-


Private Sub EnterBut_Click()

Here is my revised code.


Option Explicit

Dim oTeamMembers As Range
Dim myArray() As String

Private Sub ComboBox1_Change()
Select Case ComboBox1.ListIndex
Case 0
ListBox1.Clear

Case 1
'Redefine list for team members Team 1
myArray = Split("Dave|Rob|Sarah|Dave|Rob|Sarah|Liz|Mike", "|")
ListBox1.List = myArray
Case 2
'Redefine list for team members Team 2
myArray = Split("Mike|June|Mary|John|Steve|Maria|Liz|Andy", "|")
ListBox1.List = myArray

Case 3
'Redefine list for team members Team 3
myArray = Split("Steve|John|Mary|Ivan|Dan|Lisa|Ian|Joan", "|")
ListBox1.List = myArray

End Select

End Sub

Private Sub ListBox1_Change()
Dim lngIndex As Long, lngCOunt As Long
Dim arrTMs() As String
lngCOunt = 0
For lngIndex = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lngIndex) Then
ReDim Preserve arrTMs(lngCOunt)
lngCOunt = lngCOunt + 1
arrTMs(UBound(arrTMs)) = ListBox1.List(lngIndex)
End If
Next lngIndex
If IsArray(arrTMs) Then TextBox1 = 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 if a team has been selected
If ComboBox1.ListIndex = 0 Then
MsgBox "Select Team", vbCritical, "Triage Hub"
ComboBox1.SetFocus
Exit Sub
End If

'Check if team members have been selected
If TextBox1.Text = "" Then
MsgBox "Select Team Members", vbCritical, "Triage Hub"
TextBox1.SetFocus
Exit Sub
End If

'use FillBM function to write bookmarks
FillBM "TeamMembers", TextBox1.Text

Set oTeamMembers = Nothing
Unload Me
lbl_Exit
Exit Sub

End Sub

Private Sub UserForm_Initialize()
Dim myArray() As String
'Create list of teams
myArray = Split("- Select -|Team 1|Team 2|Team 3", "|")
'Use List method to populate ComboBox
ComboBox1.List = myArray
ComboBox1.ListIndex = 0
lbl_Exit:
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

[gmaxey]

You have to make the the listbox a multi-select list box.

[HTSCF Fareha]

You have to make the the listbox a multi-select list box.
Doh! :doh:

Apologies, this was my fault as I wasn't clear, but I was looking for the ListBox to provide a list of the names rather than as a sentence. The version you have kindly provided will obviously have its uses, although mine needs to populate into a table (two columns).

Is there a way to "store" the names selected from one team so that the list can be added to by selecting names from other teams, without the ListBox starting over again?

Thanks!

[HTSCF Fareha]

I've sorted out my 'Enter' button giving a compile error - sub or function not, but would really appreciate some help re my previous post.

With my limited knowledge I'm guessing that each "group of people" selected from a "team" will need to be stored in either an array or variable? So that these can then somehow be concatenated to populate in the ListBox.

[gmaxey]

What exactly are you trying to do?

[HTSCF Fareha]

There are three teams of people. Selections are required to be made predominantly from one team (duty team), then further people added from either of the other two teams (working as overtime). There should also be an option to add other people who do not appear in any of the three team lists too. These people could come from many other departments so it is completely impracticable to assign them to a fourth list of names.

Once all the personal have been selected, they will be added to the word document at the allotted bookmark. This will need to be as a table that has two columns. The first column with the names of those previously selected, with the second column blank so that the inputter can add any notes against the name to identify say what hours they are working / in the office / working from home etc.

My idea of using a ComboBox for the team selection was purely to try and minimise the amount of screen being taken up at any point, primarily for those using a laptop or tablet. It would be nice to be able to enter all the detail before pressing the 'Enter' button an committing the data to the form.

[HTSCF Fareha]

Still looking for some help please, Greg. Thanks!

[gmaxey]

I have given you everything you need. If you want to post your form then I'll look again. I don't have time to create your form and write your code for you. Contact me offline if you want paid consulting services.

Edit ~

I was bored.


Option Explicit
Private Const Team_A As String = "Al,Tom,Mary"
Private Const Team_B As String = "Joe,Tiny,Fat Boy"
Private Const Team_C As String = "Marge,Alice,Tuco"

Private Sub UserForm_Initialize()
With lstTeams
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
lstTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True
End Sub

Private Sub lstTeams_Change()
Dim lngIndex As Long
Dim lngSelected As Long
lstTeamMembers.Clear
For lngSelected = 0 To lstTeams.ListCount - 1
If lstTeams.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
lstTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
lstTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
lstTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub lstTeamMembers_Change()
Dim lngIndex As Long
Dim lngSelected As Long
txtTeam.Text = vbNullString
For lngSelected = 0 To lstTeamMembers.ListCount - 1
If lstTeamMembers.Selected(lngSelected) Then
txtTeam.Text = txtTeam.Text & lstTeamMembers.List(lngSelected) & ","
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim lngIndex As Long
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
For lngIndex = 0 To UBound(arrTMs)
MsgBox "Write " & arrTMs(lngIndex) & " to your document."
Next
Hide
lbl_Exit:
Exit Sub
End Sub


We are here to help you learn to write code. Not write if for you. That is what paid consultants are for. Remember:

It is not from the benevolence of the butcher, the brewer, or the baker that we expect our dinner, but from their regard to their own interest.

[HTSCF Fareha]

Greg, your help is extremely appreciated. I'm determined to learn VBA as it has so many uses.

What is the best resource to learn VBA from? I'd be really keen to develop my understanding.

Meanwhile, whilst I was "tinkering" in the background with my own coding, you had got bored and provided more code! Thanks!

Alas, it comes up with a "Compile error : Variable not defined" error here:-


Private Sub UserForm_Initialize()
With lstTeams

[gmaxey]

Seriously? Do you want something handed to you on a silver platter? Since I took the time to create a form to show you, I picked the control names.
The form must have controls named:

lstTeams
lstTeamMembers
txtTeam
and
CommandButton1

[HTSCF Fareha]

It really is not my intention to get things handed out to me. As mentioned before, I really want to learn VBA and would appreciate some guidance as to where to start. There is a wealth of stuff on the Internet, but as with everything, there is also a lot of bad information.

I am slowly picking up bits and pieces and have found this forum extremely helpful and interesting. Looking at many problems and their solutions I have tried to understand the processes that go into making good, clean and efficient coding. I'm also intrigued that in many instances there are more than a few ways of solving any particular problem.

Thanks again!

[gmaxey]

Yep. Looking at and studying lots of code, rolling your sleeves up, sitting in piles of hair (if you have any) and bloody bits of scalp is probably the best way to learn. So you have no errors now? This issue is closed?

[HTSCF Fareha]

Ha ha , no hair left I'm afraid!

Thanks for the advice.

No error codes now. Just need to get these names into the left column of a two column table then job done.

[HTSCF Fareha]

Okay, with a bit of tweaking here and there, utilizing sections of code already mentioned, I've come up with the following which works with no errors.

This allows for names to be selected from any of the three teams, then compiled into a comma delimited list, that are entered at the Bookmark 'TeamMembers'.

Forgetting the requirement for putting the names into a table.

Is there a way of having an option of adding a note (i.e. overtime, working on a different site, starting one hour after official start) alongside any of the selected names if required?


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

[HTSCF Fareha]

Regarding my last post, would I be correct in suggesting that this would require a two dimensional array?

Looking at the reply in #2, would the result be a true comma delimited list, something that could be worked into a table if required?

[gmaxey]

Again, you have been given everything you need. What you have so far failed to show is what "EXACTLY" you want as the outcome. In the last code example you sent, you have created a comma/and separated list yet you said earlier that you want your output to be a table. If so, why have you bothered with the comma/and separated list. Why are you bothering with writing to a bookmark?

In the last code I sent to you, the selected names are available in a textbox as a comma delimited list. All your user has to do is type "overtime" starting an hour later, or whatever after the persons name in the textbox and before the comma. When (if) you figure out how to with the content to the text in that textbox to the table in your document then your issue should be resolved.



Option Explicit
Private Const Team_A As String = "Al,Tom,Mary"
Private Const Team_B As String = "Joe,Tiny,Fat Boy"
Private Const Team_C As String = "Marge,Alice,Tuco"

Private Sub UserForm_Initialize()
With lstTeams
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
lstTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True
End Sub

Private Sub lstTeams_Change()
Dim lngIndex As Long
Dim lngSelected As Long
lstTeamMembers.Clear
For lngSelected = 0 To lstTeams.ListCount - 1
If lstTeams.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
lstTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
lstTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
lstTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub lstTeamMembers_Change()
Dim lngIndex As Long
Dim lngSelected As Long
txtTeam.Text = vbNullString
For lngSelected = 0 To lstTeamMembers.ListCount - 1
If lstTeamMembers.Selected(lngSelected) Then
txtTeam.Text = txtTeam.Text & lstTeamMembers.List(lngSelected) & ","
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim lngIndex As Long
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
For lngIndex = 0 To UBound(arrTMs)
MsgBox "Write " & arrTMs(lngIndex) & " to your document."
Next
Hide
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

... or you could add a couple extra command buttons to your userform to add names to textbox or add names with note to textbox:

27241

Option Explicit
Private Const Team_A As String = "Al,Tom,Mary"
Private Const Team_B As String = "Joe,Tiny,Fat Boy"
Private Const Team_C As String = "Marge,Alice,Tuco"

Private Sub UserForm_Initialize()
With lstTeams
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
lstTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True
End Sub

Private Sub lstTeams_Change()
Dim lngIndex As Long
Dim lngSelected As Long
lstTeamMembers.Clear
For lngSelected = 0 To lstTeams.ListCount - 1
If lstTeams.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
lstTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
lstTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
lstTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To lstTeamMembers.ListCount - 1
If lstTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & lstTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & lstTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
lstTeamMembers.MultiSelect = fmMultiSelectSingle
lstTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub
Private Sub cmdAddSpec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To lstTeamMembers.ListCount - 1
If lstTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & lstTeamMembers.List(lngSelected) & " - " & InputBox("Type note.")
Else
txtTeam.Text = txtTeam.Text & "," & lstTeamMembers.List(lngSelected) & " - " & InputBox("Type note.")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub

End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim lngIndex As Long
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
For lngIndex = 0 To UBound(arrTMs)
MsgBox "Write " & arrTMs(lngIndex) & " to your document."
Next
Hide
lbl_Exit:
Exit Sub
End Sub

[HTSCF Fareha]

Sorry for leaving it so long in replying. Only just managed to find a bit of time to catch up!

I agree that I might've complicated my requirements with the last piece of code I posted.

(I think that I confuse myself with changing tact too).

Okay, stop, think, explain .......

The userform as per your last post looks ideal for what I am trying to achieve. Yes, I do need to send the data to a table two columns wide. The name should appear in the left column and the note in the right hand one. Is there a way of not having the prompt to add each name? Would this be a case of removing


MsgBox "Write " & arrTMs(lngIndex) & " to your document."

To avoid using bookmarks, how would one position the table in the correct place in the document? This is what the document should be looking like:-

27257

I'm also thinking that I would need the table to add the two respective headings (Name & Notes) when sending the data to the document?

Am I correct in my thinking that this is someway along what I am looking to utilize?


Sub TextToTable()
With Documents.Add.Content
.InsertBefore "one" & vbTab & "two" & vbTab & "three" & vbTab & "four" & vbTab & "five" & vbTab & "six" & vbCr
.ConvertToTable Separator:=Chr(9), NumColumns:=2, applyborders:=True, AutoFit:=True
Selection.Tables(1).PreferredWidth = 300
End With
End Sub

Thanks again!

[HTSCF Fareha]

Is there a way of not having the prompt to add each name? Would this be a case of removing


MsgBox "Write " & arrTMs(lngIndex) & " to your document."

[Update] Yes, removing this does remove the prompt.

[gmaxey]

Again, you have been given everything


Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim arrParts() As String
Dim lngIndex As Long
Dim oTbl As Table
Dim oRow As Row
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
'Your template should already have a table (at least two rows with the headings defined in row 1).
Set oTbl = ActiveDocument.Tables(1) 'or whatever table it is.
On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. No add a row.
If oRow Is Nothing Then Set oRow = oTbl.Rows.Add
oTbl.Cell(lngIndex + 2, 1).Range.Text = arrParts(0)
If UBound(arrParts) > 0 Then oTbl.Cell(lngIndex + 2, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0
Hide
lbl_Exit:
Exit Sub
End Sub

[HTSCF Fareha]

Many thanks, Greg. This is exactly what was needed! :)

One thing that I have noticed is that once a name has been selected, it can be selected and entered more than once?

[gmaxey]

You don't know when to quit do you?

Don't select is twice or use code to remove it from the list. Again, do you want to learn to fish or just have someone keep handing you fish?


Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To lstTeamMembers.ListCount - 1
If lstTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & lstTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & lstTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = lstTeamMembers.ListCount - 1 To 0 Step -1
If lstTeamMembers.Selected(lngSelected) Then
lstTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
lstTeamMembers.MultiSelect = fmMultiSelectSingle
lstTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

[HTSCF Fareha]

Many thanks for your patience and help!

Please believe me that aside from asking for your help, I am looking very carefully at the code you provide to try and understand what is happening and why.

[gmaxey]

You're welcome. Just trying to shame you into learning it for yourself. You'll never know it all, but when you start answering more questions than you ask, you'll be off to a very good start.

[HTSCF Fareha]

Wise words indeed!

I've still plenty to be working on this form before it is finished, so there are still more things for me to try and fathom out.

These include:-

1) Adapting it to enter the details into the third table on the form - Sorted.
2) Entering the details from the third row onwards (top row already has merged cells with the table's title in it, with the second row containing the two headings), rather than after the second row - Still to do.
27261

3) This will complete things for the "day shift", although the "late shift" will need another table and on the same form - Still to do.

I'm going to have a good go at trying to sort this. :think:

[HTSCF Fareha]

Making some progress in my project. I've added some extra buttons to the form to allow for day and late shifts to be added.

27265

When commiting the names to the two tables (Execute button), these are getting confused and trying to put all the names in table 3 (Days), instead of table 3 (Days) and table 4 (Lates). Gonna have to ask for some more help please.


Option Explicit
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 T,John,Mary,Ivan,Dan,Lisa,Ian,Joan"

Private Sub UserForm_Initialize()
With TeamDay
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
DayTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True

With TeamLates
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
LateTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam1.MultiLine = True

End Sub

Private Sub TeamDay_Change()
Dim lngIndex As Long
Dim lngSelected As Long
DayTeamMembers.Clear
For lngSelected = 0 To TeamDay.ListCount - 1
If TeamDay.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
DayTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
DayTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
DayTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub TeamLates_Change()
Dim lngIndex As Long
Dim lngSelected As Long
LateTeamMembers.Clear
For lngSelected = 0 To TeamLates.ListCount - 1
If TeamLates.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
LateTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
LateTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
LateTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = DayTeamMembers.ListCount - 1 To 0 Step -1
If DayTeamMembers.Selected(lngSelected) Then
DayTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
DayTeamMembers.MultiSelect = fmMultiSelectSingle
DayTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected)
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = LateTeamMembers.ListCount - 1 To 0 Step -1
If LateTeamMembers.Selected(lngSelected) Then
LateTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
LateTeamMembers.MultiSelect = fmMultiSelectSingle
LateTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAddSpec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1Spec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim arrParts() As String
Dim lngIndex As Long
Dim oTbl1 As Table, oTbl2 As Table
Dim oRow As Row
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
If Right(txtTeam1.Text, 1) = "," Then txtTeam1.Text = Left(txtTeam1.Text, Len(txtTeam1.Text) - 1)
arrTMs = Split(txtTeam1, ",")
'Your template should already have a table (at least two rows with the headings defined in row 1).
Set oTbl1 = ActiveDocument.Tables(3) 'Select first table number
Set oTbl2 = ActiveDocument.Tables(4) 'Select second table number
On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl1.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow Is Nothing Then Set oRow = oTbl1.Rows.Add
oTbl1.Cell(lngIndex + 2, 1).Range.Text = arrParts(0)
If UBound(arrParts) > 0 Then oTbl1.Cell(lngIndex + 2, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0
Hide
lbl_Exit:
Exit Sub
End Sub

[HTSCF Fareha]

I think I'm getting there, but cannot fathom out how to get the names to populate from the third row in each table.


Option Explicit
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 T,John,Mary,Ivan,Dan,Lisa,Ian,Joan"

Private Sub UserForm_Initialize()
With TeamDay
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
DayTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True

With TeamLates
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
LateTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam1.MultiLine = True

End Sub

Private Sub TeamDay_Change()
Dim lngIndex As Long
Dim lngSelected As Long
DayTeamMembers.Clear
For lngSelected = 0 To TeamDay.ListCount - 1
If TeamDay.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
DayTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
DayTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
DayTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub TeamLates_Change()
Dim lngIndex As Long
Dim lngSelected As Long
LateTeamMembers.Clear
For lngSelected = 0 To TeamLates.ListCount - 1
If TeamLates.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
LateTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
LateTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
LateTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = DayTeamMembers.ListCount - 1 To 0 Step -1
If DayTeamMembers.Selected(lngSelected) Then
DayTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
DayTeamMembers.MultiSelect = fmMultiSelectSingle
DayTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected)
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = LateTeamMembers.ListCount - 1 To 0 Step -1
If LateTeamMembers.Selected(lngSelected) Then
LateTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
LateTeamMembers.MultiSelect = fmMultiSelectSingle
LateTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAddSpec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1Spec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim arrTMs1() As String
Dim arrParts() As String
Dim lngIndex As Long
Dim lngIndex1 As Long
Dim oTbl1 As Table, oTbl2 As Table
Dim oRow As Row
Dim oRow1 As Row
If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
If Right(txtTeam1.Text, 1) = "," Then txtTeam1.Text = Left(txtTeam1.Text, Len(txtTeam1.Text) - 1)
arrTMs1 = Split(txtTeam1, ",")
'Your template should already have a table (at least two rows with the headings defined in row 1).
Set oTbl1 = ActiveDocument.Tables(3) 'Select first table number
Set oTbl2 = ActiveDocument.Tables(4) 'Select second table number
On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl1.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow Is Nothing Then Set oRow = oTbl1.Rows.Add
oTbl1.Cell(lngIndex + 2, 1).Range.Text = arrParts(0)
If UBound(arrParts) > 0 Then oTbl1.Cell(lngIndex + 2, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0

On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex1 = 0 To UBound(arrTMs1)
arrParts = Split(arrTMs1(lngIndex1), " - ")
Set oRow1 = oTbl2.Rows(lngIndex1 + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow1 Is Nothing Then Set oRow1 = oTbl2.Rows.Add
oTbl2.Cell(lngIndex1 + 2, 1).Range.Text = arrParts(0)
If UBound(arrParts) > 0 Then oTbl2.Cell(lngIndex1 + 2, 2).Range.Text = arrParts(1)
Set oRow1 = Nothing
Next
On Error GoTo 0

Hide
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

If it were a snake, I think it would have bitten you. lngIndex starts at 0. If you want to start writing to the third row then change lngIndex + 2 to lngIndex + 3.

... and you don't really need the second set of varialbes arrTMs1, oTbl2 etc. Rearrange your code so when you finish the first loop, start again with:

If Right(txtTeam1.Text, 1) = "," Then txtTeam1.Text = Left(txtTeam1.Text, Len(txtTeam1.Text) - 1)
arrTMs = Split(txtTeam1, ",")
Set oTbl = ActiveDocument.Tables(4)

[HTSCF Fareha]

Fabulous, many thanks!! :thumb

I was looking for something around the 'row' rather than 'lngIndex'.

Thanks for the other tip re the loop. I'm guessing this is so that this keeps the code more efficient and file size smaller?

The only thing that is not working completely correctly is if a name is selected and a note added, the name is not removed from the list of available team members. Tiny point I know, but would be great to sort.


Option Explicit
Private Const Team_A As String = "Dave,Rob,Sarah,Dave R,Rob L,Sarah,Liz,Mike"
Private Const Team_B As String = "Mike,June,Mary,John,Steve,Maria,Liz M,Andy"
Private Const Team_C As String = "Steve T,John,Mary,Ivan,Dan,Lisa,Ian,Joan"

Private Sub UserForm_Initialize()
With TeamDay
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
DayTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True

With TeamLates
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
LateTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam1.MultiLine = True

End Sub

Private Sub TeamDay_Change()
Dim lngIndex As Long
Dim lngSelected As Long
DayTeamMembers.Clear
For lngSelected = 0 To TeamDay.ListCount - 1
If TeamDay.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
DayTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
DayTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
DayTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub TeamLates_Change()
Dim lngIndex As Long
Dim lngSelected As Long
LateTeamMembers.Clear
For lngSelected = 0 To TeamLates.ListCount - 1
If TeamLates.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
LateTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
LateTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
LateTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = DayTeamMembers.ListCount - 1 To 0 Step -1
If DayTeamMembers.Selected(lngSelected) Then
DayTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
DayTeamMembers.MultiSelect = fmMultiSelectSingle
DayTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected)
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = LateTeamMembers.ListCount - 1 To 0 Step -1
If LateTeamMembers.Selected(lngSelected) Then
LateTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
LateTeamMembers.MultiSelect = fmMultiSelectSingle
LateTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAddSpec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1Spec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
End If
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

'Reset button
Private Sub ResetBut_Click()
Dim ctl As MSForms.Control

For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""

End Select
Next ctl
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim arrParts() As String
Dim lngIndex As Long
Dim oTbl As Table
Dim oRow As Row

If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
Set oTbl = ActiveDocument.Tables(3) 'Select first table
If Right(txtTeam1.Text, 1) = "," Then txtTeam1.Text = Left(txtTeam1.Text, Len(txtTeam1.Text) - 1)
arrTMs = Split(txtTeam1, ",")
Set oTbl = ActiveDocument.Tables(4) 'Select second table

On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow Is Nothing Then Set oRow = oTbl.Rows.Add
oTbl.Cell(lngIndex + 3, 1).Range.Text = arrParts(0) 'Start table at row 3
If UBound(arrParts) > 0 Then oTbl.Cell(lngIndex + 2, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0

Hide
lbl_Exit:
Exit Sub
End Sub

[HTSCF Fareha]

Didn't mean to enter anything! Doh! :crying:

[gmaxey]

That would be because you don't have code in your cmdAddSpec click event to remove the selected items.

[HTSCF Fareha]

Of course, yes! Finally completely finished!! Phew!!!

Many thanks, gmaxey. :thumb

[gmaxey]

So why don't you post your final code (better yet the document).

[HTSCF Fareha]

Here is the final code (cannot put the whole document up for security reasons, sorry). Thanks again to gmaxey!!


Option Explicit
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 T,John,Mary,Ivan,Dan,Lisa,Ian,Joan"
Private Sub UserForm_Initialize()
With TeamDay
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
DayTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam.MultiLine = True

With TeamLates
.MultiSelect = fmMultiSelectMulti
.AddItem "Team A"
.AddItem "Team B"
.AddItem "Team C"
End With
LateTeamMembers.MultiSelect = fmMultiSelectMulti
txtTeam1.MultiLine = True

End Sub

Private Sub TeamDay_Change()
Dim lngIndex As Long
Dim lngSelected As Long
DayTeamMembers.Clear
For lngSelected = 0 To TeamDay.ListCount - 1
If TeamDay.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
DayTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
DayTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
DayTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub TeamLates_Change()
Dim lngIndex As Long
Dim lngSelected As Long
LateTeamMembers.Clear
For lngSelected = 0 To TeamLates.ListCount - 1
If TeamLates.Selected(lngSelected) Then
Select Case lngSelected
Case 0
For lngIndex = 0 To UBound(Split(Team_A, ","))
LateTeamMembers.AddItem Split(Team_A, ",")(lngIndex)
Next
Case 1
For lngIndex = 0 To UBound(Split(Team_B, ","))
LateTeamMembers.AddItem Split(Team_B, ",")(lngIndex)
Next
Case 2
For lngIndex = 0 To UBound(Split(Team_C, ","))
LateTeamMembers.AddItem Split(Team_C, ",")(lngIndex)
Next
End Select
End If
Next lngSelected
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected)
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = DayTeamMembers.ListCount - 1 To 0 Step -1
If DayTeamMembers.Selected(lngSelected) Then
DayTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
DayTeamMembers.MultiSelect = fmMultiSelectSingle
DayTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected)
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected)
End If
End If
Next lngSelected
For lngSelected = LateTeamMembers.ListCount - 1 To 0 Step -1
If LateTeamMembers.Selected(lngSelected) Then
LateTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
LateTeamMembers.MultiSelect = fmMultiSelectSingle
LateTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAddSpec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To DayTeamMembers.ListCount - 1
If DayTeamMembers.Selected(lngSelected) Then
If txtTeam = vbNullString Then
txtTeam.Text = txtTeam.Text & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
Else
txtTeam.Text = txtTeam.Text & "," & DayTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
End If
End If
Next lngSelected
For lngSelected = DayTeamMembers.ListCount - 1 To 0 Step -1
If DayTeamMembers.Selected(lngSelected) Then
DayTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
DayTeamMembers.MultiSelect = fmMultiSelectSingle
DayTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

Private Sub cmdAdd1Spec_Click()
Dim lngIndex As Long
Dim lngSelected As Long
For lngSelected = 0 To LateTeamMembers.ListCount - 1
If LateTeamMembers.Selected(lngSelected) Then
If txtTeam1 = vbNullString Then
txtTeam1.Text = txtTeam1.Text & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
Else
txtTeam1.Text = txtTeam1.Text & "," & LateTeamMembers.List(lngSelected) & " - " & InputBox("Type note", "Triage Hub")
End If
End If
Next lngSelected
For lngSelected = LateTeamMembers.ListCount - 1 To 0 Step -1
If LateTeamMembers.Selected(lngSelected) Then
LateTeamMembers.RemoveItem lngSelected
End If
Next lngSelected
LateTeamMembers.MultiSelect = fmMultiSelectSingle
LateTeamMembers.MultiSelect = fmMultiSelectMulti
lbl_Exit:
Exit Sub
End Sub

'Reset button
Private Sub ResetBut_Click()
Unload Me
UserForm.Show
End Sub

Private Sub CommandButton1_Click()
Dim arrTMs() As String
Dim arrParts() As String
Dim lngIndex As Long
Dim oTbl As Table
Dim oRow As Row

If txtTeam.Text = "" Then
MsgBox "Enter Days Team", vbCritical, "Triage Hub"
DayTeamMembers.SetFocus
Exit Sub
End If
If txtTeam1.Text = "" Then
MsgBox "Enter Lates Team", vbCritical, "Triage Hub"
LateTeamMembers.SetFocus
Exit Sub
End If

If Right(txtTeam.Text, 1) = "," Then txtTeam.Text = Left(txtTeam.Text, Len(txtTeam.Text) - 1)
arrTMs = Split(txtTeam, ",")
Set oTbl = ActiveDocument.Tables(3) 'Select first table

On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow Is Nothing Then Set oRow = oTbl.Rows.Add
oTbl.Cell(lngIndex + 3, 1).Range.Text = arrParts(0) 'Start table at row 3
If UBound(arrParts) > 0 Then oTbl.Cell(lngIndex + 3, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0

If Right(txtTeam1.Text, 1) = "," Then txtTeam1.Text = Left(txtTeam1.Text, Len(txtTeam1.Text) - 1)
arrTMs = Split(txtTeam1, ",")
Set oTbl = ActiveDocument.Tables(4) 'Select second table

On Error Resume Next 'If there are more team members than rows then you are going to hit an error on ***
For lngIndex = 0 To UBound(arrTMs)
arrParts = Split(arrTMs(lngIndex), " - ")
Set oRow = oTbl.Rows(lngIndex + 2) '***
'Since there is no row and you handled the error oRow will be nothing. Now add a row.
If oRow Is Nothing Then Set oRow = oTbl.Rows.Add
oTbl.Cell(lngIndex + 3, 1).Range.Text = arrParts(0) 'Start table at row 3
If UBound(arrParts) > 0 Then oTbl.Cell(lngIndex + 3, 2).Range.Text = arrParts(1)
Set oRow = Nothing
Next
On Error GoTo 0

Hide
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Nobody wants to rebuild your form. Send the document to me and I'll post it here.

[HTSCF Fareha]

Erm, I have no way of attaching my document. :banghead:

The security issue was nothing to do with trying to upload it, rather that the information on it is sensitive. I've removed the sensitive stuff and am more than happy to share the form. Just need to know how. According to the posting permissions I am allowed to do this, I just can't see how.

[gmaxey]

Click on the Go Advanced button and upload the file.

[HTSCF Fareha]

Yeah, I have the advanced option okay, but when I try to upload the document it states that it is an invalid file type. This is annoying as it clearly states that a .dotm file is permitted.

[gmaxey]

Try saving it as a docm and try again or send it to me and I'll post it.

[HTSCF Fareha]

Here is my form. Hope that this helps others too!27280

[gmaxey]

I don't know what you attached, but it isn't a file with a userform and code. Why don't you just send me the file by contacting me via my weblink.

[HTSCF Fareha]

Sorted!

[gmaxey]

I don't know what you think you sorted, but if I download that attached file and attempt to open it nothing happens. Word simply opens with a new blank document. No file name, no code, no userform.

[HTSCF Fareha]

Does it make a difference if the file extension is changed back to .dotm

[gmaxey]

No. Last time. Send me the file and I will post it or just forget about it.

[HTSCF Fareha]

Sent it as an attachment to your private email.

[gmaxey]

Steve (the OP) and I have collaborated offline a bit on the development of his form. The end result is attached:

27290