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?
Printable View
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.
Code: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:
Attachment 27241
Code: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:-Code:MsgBox "Write " & arrTMs(lngIndex) & " to your document."
Attachment 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?
Thanks again!Code: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
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.Code:MsgBox "Write " & arrTMs(lngIndex) & " to your document."
Again, you have been given everything
Code: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?
Code: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.
Attachment 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:
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.
Attachment 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.
Code: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.
Code: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!! :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.
Code: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! :crying:
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. :thumb
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!!
Code: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