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?
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?
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
... or you could add a couple extra command buttons to your userform to add names to textbox or add names with note to textbox:
2020-09-30_10-47-04.jpg
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
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
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:-MsgBox "Write " & arrTMs(lngIndex) & " to your document."
2020-10-02_180137.jpg
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?
Thanks again!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
Last edited by HTSCF Fareha; 10-02-2020 at 01:29 PM.
Is there a way of not having the prompt to add each name? Would this be a case of removing
[Update] Yes, removing this does remove the prompt.MsgBox "Write " & arrTMs(lngIndex) & " to your document."
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
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?
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
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.
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.
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.
2020-10-03_220418.png
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.
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.
2020-10-04_175214.jpg
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
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
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)
Fabulous, many thanks!!
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
Didn't mean to enter anything! Doh!
That would be because you don't have code in your cmdAddSpec click event to remove the selected items.
Of course, yes! Finally completely finished!! Phew!!!
Many thanks, gmaxey.
So why don't you post your final code (better yet the document).
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