Consulting

Page 2 of 3 FirstFirst 1 2 3 LastLast
Results 21 to 40 of 53

Thread: Selecting a team from a ListBox

  1. #21
    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?

  2. #22
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  3. #23
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    ... 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
    Greg

    Visit my website: http://gregmaxey.com

  4. #24
    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:-

    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?

    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!
    Last edited by HTSCF Fareha; 10-02-2020 at 01:29 PM.

  5. #25
    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.

  6. #26
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  7. #27
    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?

  8. #28
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  9. #29
    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.

  10. #30
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  11. #31
    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.

  12. #32
    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
    Attached Images Attached Images

  13. #33
    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

  14. #34
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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)
    Greg

    Visit my website: http://gregmaxey.com

  15. #35
    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

  16. #36
    Didn't mean to enter anything! Doh!

  17. #37
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    That would be because you don't have code in your cmdAddSpec click event to remove the selected items.
    Greg

    Visit my website: http://gregmaxey.com

  18. #38
    Of course, yes! Finally completely finished!! Phew!!!

    Many thanks, gmaxey.

  19. #39
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    So why don't you post your final code (better yet the document).
    Greg

    Visit my website: http://gregmaxey.com

  20. #40
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •