Populate multiselect + options listbox on Userform with previous output

qapla47

New Member
Joined
Jun 23, 2016
Messages
24
HiFolks,
I'm trying to create a userform that will checkto see if information related to the current row had already been recorded to a different worksheet (Worksheet1 is the active one, worksheet3 holds the information),and pre-populate the checkmarks on a multi-select option listbox with information if it already had been added to a secondary worksheet. Then, once the user hadupdated the form, and pressed the update button, it would export thatinformation into worksheet 3.

Basically what I have is that certain job typesrequire extra processing, and I want to use a userform to create a checklist ofprocesses that need to be performed before the job is complete. Steps that arenot required for other types of jobs.

My pseudo code thinking:
When the userform is opened, it pulls in the job# of the current row (which is in colA of sheet 1).

if userform job# = job# field in column A ofworksheet3 (also job#) then populate the checkboxes with the values foundin columns B-N (which correspond to the checklist boxes in the userform)
User updates the checkboxes (amulti-select listbox with options, which populates from a named range on sheet2), and then clicks the "Update" button - which triggers the form tofill the columns with data (or overwrite as need). User clicks the "CloseForm" button, which exits the form.

Else add new row to bottom of Mailing Jobsworksheet (Sheet3) and fill with the check box values when the user clicks"Update". User clicks the "Close Form" button, which exitsthe form.

If col M = "Ready to Deliver", removecorresponding line from the Mailing Jobs worksheet (this I think get's added tomy existing code surrounding col M event changes)

I'm using a form control button on sheet1 to trigger the Userform (MailingTaskList). The Userform has a text box (JobNumber), the multiselect option listbox (MailingCheckList), and two command buttons (UpdateForm and CloseForm).

Here's what I have for code at present whichobviously doesn't do everything above. It will add a line to the secondary worksheet, and exports the label of the chosen option from the checklist (I'd rather it just said T/F or Y/N, as there is a header in my sheet). It doesn't get far enough to check forprevious iterations, let alone bring in information that it might find there.

I've been plugging away at this for some time, and am hoping someone can point me in the right direction? Or show/explain what needs to happen here?

My code for the Userform:
Code:
Private Sub CloseForm_Click()
Unload Me
End Sub


'This segment does nothing, as yet - an attempt to bring in keyboard strokes as event handlers, and populate the checklist options based on previous input - the single quote are parts that I know to work in some fashion, the triples are code that I'm working on from another example


'  Private Sub JobNumber_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   '     If KeyCode = vbKeyReturn Then
'''Dim DataSH As Worksheet
  '''Set DataSH = Sheets("MailingJobs")
  '''DataSH.Range("A2").Value = JobNumber.Text
  '''DataSH.Range("A2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=DataSH.Range("P2:P3"), copytorange:=DataSH.Range("B2:N2")
  '''MailingCheckList.RowSource = "MailingJobs" & DataSH.Range("outdata").Address
 ' Dim FindMe As Variant, FindCell As Range
    'With Range("BLANK")
      '  FindMe = JobNumber
       ' Set FindCell = .Cells.Find(What:=FindMe, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart _
       ' , SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
       ' If Not FindCell Is Nothing Then
            '''tbxBlankAccount.Value = FindCell(1, 1).Value
            '''tbxBlankName.Value = FindCell(1, 2).Value
            '''tbxBlankShort.Value = FindCell(1, 3).Value
           ' MailingCheckList.Value = ""
       ' Else
           ' MsgBox "Search Criteria - " & FindMe & " Was Not Found", vbExclamation
        'End If
   ' End With
'End If
'End Sub


Private Sub UpdateForm_Click()
'this code works to place selected items from list box into sheet7
'it only places data into the next empty row, it does not search and update
    Dim i
    Dim lRow As Long
    Dim emptyRow As Long
    Dim lItem As Long
    Dim Found As Range
    Dim str As String
        
    With Sheets("MailingJobs")
     
        str = Me.JobNumber.Text
        Set Found = Worksheets("Sheet7").Range(Worksheets("Sheet7").Range("A2"), Worksheets("Sheet7").Range("A" & Rows.Count).End(xlUp)).Find(str)
'Worksheets("Sheet2").Range(Worksheets("Sheet2"). _
    Range("A1"), Worksheets("Sheet2").Range("A7")))
        If Found Is Nothing Then
            
            'this segment was working before the if was added to the IF
            emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
            Cells(emptyRow, 1).Value = JobNumber.Value
         
            For i = 0 To MailingCheckList.ListCount - 1
                If MailingCheckList.Selected(i) Then
                 .Cells(emptyRow, i + 2) = MailingCheckList.List(lItem)
                End If
            Next i
        Else
            MsgBox ("Already There!")
        End If 'belongs to the if found is nothing line above
    End With
End Sub

There are many things in my Sheet1, provided to help prevent interactions:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)'Update 20160721


Dim WorkRng As Range
Dim rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("M:M"), Target)
xOffsetColumn = 3
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each rng In WorkRng


        'If the value of M toggles to Approved/Ready to Print, place the date in Changes (N)
        If rng.Value = "Approved" Then
            rng.Offset(, 1).Value = Now
            rng.Offset(, 1).NumberFormat = "dd mmm"
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Ready to Print" Then
            rng.Offset(, 1).Value = Now
            rng.Offset(, 1).NumberFormat = "dd mmm"
            ThisWorkbook.Save
        End If
        
        'If the value of M toggles to Proof (any variant), clear the contents of Priority (Q)
        If rng.Value = "Proof" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Proof 2" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Proof 3" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Hard Proof" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Hard Proof 2" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Hard Proof 3" Then
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        'If the value of Status (M) toggles to Plated, save the workbook
        If rng.Value = "Plated" Then
            ThisWorkbook.Save
        End If
        
        'If the value of M toggles to Approved, copy S (next location) into R (current location), and clear priority (Q)
        If rng.Value = "Approved" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            If rng.Offset(, 2).Value = "trim" Then
            rng.Offset(, 6).Value = "Bindery"
            End If
            If (InStr(1, (rng.Offset(, 2).Value), "to Produce") > 0 Or InStr(1, (rng.Offset(, 2).Value), "to convert") > 0 Or InStr(1, (rng.Offset(, 2).Value), "to Laminate") > 0) And InStr(1, (rng.Offset(, 2).Value), "Epi") = 0 Then
            rng.Offset(, 6).Value = "Outside"
            End If
            If (InStr(1, (rng.Offset(, 2).Value), "to Produce") > 0 Or InStr(1, (rng.Offset(, 2).Value), "to convert") > 0 Or InStr(1, (rng.Offset(, 2).Value), "to Laminate") > 0) And InStr(1, (rng.Offset(, 2).Value), "Epi") > 0 Then
            rng.Offset(, 6).Value = "H Assem"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "die cut") > 0 Then
            rng.Offset(, 6).Value = "Die Cut"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "trim") > 0 And InStr(1, (rng.Offset(, 2).Value), "die cut") = 0 Then
            rng.Offset(, 6).Value = "Bindery"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "trim") > 0 And InStr(1, (rng.Offset(, 2).Value), "die cut") > 0 Then
            rng.Offset(, 6).Value = "Die Cut"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "flat sheets") > 0 Then
            rng.Offset(, 6).Value = "Delivery"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "rebox") > 0 Then
            rng.Offset(, 6).Value = "Delivery"
            End If
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Printing X" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            If InStr(1, (rng.Offset(, 2).Value), "trim") > 0 Then
            rng.Offset(, 6).Value = "Delivery"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "assemble") > 0 Then
            rng.Offset(, 6).Value = "H Assem"
            End If
            If InStr(1, (rng.Offset(, 2).Value), "assemble") = 0 And InStr(1, (rng.Offset(, 2).Value), "die cut") > 0 Then
            rng.Offset(, 6).Value = "Delivery"
            End If
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Production X" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Complete" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "H.Assem. X" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Bind X" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            If InStr(1, (rng.Offset(, 2).Value), "assemble") > 0 Then
            rng.Offset(, 6).Value = "H Assem"
            End If
            ThisWorkbook.Save
        End If
        
        If rng.Value = "Die Cut X" Then
            rng.Offset(, 5).Value = Cells(Application.ActiveCell.Row, 19)
            rng.Offset(, 4).ClearContents
            If InStr(1, (rng.Offset(, 2).Value), "assemble") > 0 Then
            rng.Offset(, 6).Value = "Delivery"
            End If
            ThisWorkbook.Save
        End If
        
        If rng.Value = "On Hold" Then
            rng.Offset(, 1).Value = Now
            rng.Offset(, 1).NumberFormat = "dd mmm"
            rng.Offset(, 4).ClearContents
            rng.Offset(, 6).Value = Cells(Application.ActiveCell.Row, 18)
            rng.Offset(, 5).Value = "Hold"
            ThisWorkbook.Save
        End If
        
        If Not VBA.IsEmpty(rng.Value) Then
            rng.Offset(0, xOffsetColumn).Value = Now
            rng.Offset(0, xOffsetColumn).NumberFormat = "dd mmm"
            ThisWorkbook.Save
        Else
            rng.Offset(0, xOffsetColumn).ClearContents
            ThisWorkbook.Save
        End If


    Next


    Application.EnableEvents = True
End If
End Sub

And a few calls in my ThisWorkbook, again provided to prevent interactions:
Code:
'DO NOT DELETE!'This section for saving and applying the header to the file
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:06:30"), "SaveThis"
Application.OnTime TimeValue("09:00:00"), "Test"
Application.OnTime TimeValue("19:00:00"), "CloseAllWorkbooks"
Application.OnTime TimeValue("7:01 PM"), "CloseAllWorkbooks"
End Sub
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Forum statistics

Threads
1,215,584
Messages
6,125,677
Members
449,248
Latest member
wayneho98

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top