asked on
Preselect listbox items and map to another listbox

Expert,

I need a script to add to a user form that maps list of items when one of the items from the list is selected. it will automatically map to the associated item. For example, If I select with a check box from License Type - Customer Community, it will automatically pull into the form from License Type 2 - Community and so on.

For Example:

License Type List License Type 2 List
customer Community Community
Partner Community Community
Additional 10 Object Community Add-On
Force.com, Unlimited Ed Force.com
Email Messages Marketing Cloud

I am not that familiar with VBA so would need to know where to place the script..

Current user form Code is below:
Option Explicit
Dim rData As Range, Cl As Range
Dim oWs As Worksheet
Dim lRw As Long, T As Long, P As Long, lPos As Long
Dim iX As Integer, iCol As Integer
Dim bInit As Boolean, bEdit As Boolean


Private Sub cboFind_Change()
    Dim cUnique As Collection
    Dim vNum As Variant

    Me.cmdSearch.Enabled = Me.cboFind.ListIndex > -1
    iCol = Choose(Me.cboFind.ListIndex + 1, 4, 2, 5, 16)

    Set cUnique = New Collection

    On Error Resume Next
    For Each Cl In rData.Columns(iCol).Cells
        cUnique.Add Cl.Value, CStr(Cl.Value)
    Next Cl
    On Error GoTo 0

    For Each vNum In cUnique
        Me.cboCriteria.AddItem vNum
    Next vNum
End Sub



Private Sub chkNew_Click()

    If chkNew Then
        lPos = Me.lbxData.ListIndex
        ClearAll Me
        Me.editstudent2.Value = Application.WorksheetFunction.Max(rData.Columns(2)) + 1
    Else: Me.lbxData.ListIndex = lPos
    End If
    
    Me.cmdAdd.Enabled = chkNew
    bEdit = chkNew
End Sub

Private Sub cmdAdd_Click()

    WriteToSheet
End Sub

Private Sub cmdSearch_Click()
    Dim TempSht As Worksheet, rTemp As Range
    Dim lIndex As Long, lTot As Long

'    If Not oWs.Range("A4").AutoFilter Then oWs.Range("A4").AutoFilter

    If oWs.FilterMode Then oWs.ShowAllData

    Set TempSht = Worksheets.Add
    rData.AutoFilter Field:=iCol, Criteria1:=Me.cboCriteria.Value
    rData.Copy
    With TempSht

        .Cells(1).PasteSpecial xlAll
        Me.lbxData.Clear
        Set rTemp = .Range(.Cells(2, 1), .Cells(.Rows.Count, 15).End(xlUp))
        Set rTemp = rTemp.Resize(rTemp.Rows.Count + 2, rTemp.Columns.Count)
        rTemp.Columns.AutoFit
        ColumnWidths rTemp
        With Me.lbxData
            .List = rTemp.Value
            .AddItem
            .List(.ListCount - 2, 4) = "TOTAL: " & Me.cboFind.Value & "  " & Me.cboCriteria.Value
            For lIndex = 0 To .ListCount - 1
                If IsNumeric(.List(lIndex, 12)) Then
                    lTot = lTot + .List(lIndex, 12)
                End If
            Next
            .List(.ListCount - 2, 12) = "Qty: " & lTot

            For lIndex = 0 To .ListCount - 1
                If IsNumeric(.List(lIndex, 13)) Then
                    lTot = lTot + .List(lIndex, 13)
                End If
            Next
            .List(.ListCount - 2, 13) = lTot
            .List(.ListCount - 2, 13) = FormatCurrency(.List(.ListCount - 2, 13))
            lTot = 0
        End With
        Application.DisplayAlerts = False
        TempSht.Delete
        Application.DisplayAlerts = True
        oWs.ShowAllData
    End With
End Sub


Private Sub editstudent1_Enter()
    If Not bInit Then Exit Sub
    g_bForm = True
    frmCalendar.Show_Cal
    Me.editstudent1.Value = g_sDate
End Sub

Private Sub editstudent10_Enter()
    If Not bInit Then Exit Sub
    g_bForm = True
    frmCalendar.Show_Cal
    Me.editstudent10.Value = g_sDate
End Sub

Private Sub editstudent9_Enter()
    If Not bInit Then Exit Sub
    g_bForm = True
    frmCalendar.Show_Cal
    Me.editstudent9.Value = g_sDate
End Sub

Private Sub imgDone_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With Me.fraSearch
        .Top = T
        .Left = P
        .Visible = False
    End With

    With Me.lbxData
        .Clear
        .ColumnCount = 19
        .List = rData.Offset(1).Resize(rData.Rows.Count - 1, _
                                       19).Value
        .ListIndex = 0
        lRw = .ListIndex
    End With
End Sub



Private Sub imgSearch_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With Me.fraSearch
        T = .Top
        P = .Left
        .Top = Me.imgSearch.Top
        .Left = Me.cmdUpdate.Left
        .Visible = True
    End With
End Sub


Private Sub lblViewAll_Click()

    With Me.lblViewAll
        If .Caption = "View all columns" Then
            .Caption = "Compact view"
            With Me
                .lbxData.Width = Evaluate(Replace(Replace(.lbxData.ColumnWidths, ";", "+"), " pt", "")) + 10
                .lbxData.Height = .lbxData.Height * 1.25
                .lbxHeader.Width = .lbxData.Width
                .Height = Application.Height
                .Width = Application.Width
                .Left = Application.Left
                .Top = Application.Top
            End With
        Else:
            Unload Me
            frmeditrecord.Show
        End If
    End With

End Sub

Private Sub lbxData_Click()
    lRw = Me.lbxData.ListIndex
    LoadBoxes
End Sub



Private Sub UserForm_Initialize()

    Set oWs = Sheet1
    With oWs
        Set rData = .Range(.Cells(3, 1), .Cells(.Rows.Count, 26).End(xlUp))
    End With
    
    editstudent1.SetFocus

    With Me
        .lblCap.Caption = "Add or Edit Records"
        .cboFind.List = Array("Quote #", "Ref#", "License Type", "License Type 2")
        .cmdSearch.Enabled = .cboFind.ListIndex > -1
        .Width = 810
        .Height = 560
    End With

    For iX = 1 To 13
        Me("lbl" & iX).Caption = rData.Cells(1, iX).Value
    Next iX

    For iX = 14 To 17
        Me("lbl" & iX).Caption = rData.Cells(1, iX + 2).Value
    Next iX

    ColumnWidths rData
    Me.lbxData.ListIndex = Me.lbxData.ListCount - 1
    LoadBoxes
    bInit = True
End Sub

Sub ColumnWidths(r As Range)
    Dim CW As String
    With Me.lbxData
        .ColumnCount = 19
        .List = rData.Offset(1).Resize(rData.Rows.Count - 1, _
                                       19).Value
        .ListIndex = 0
        CW = ""
        ''///match ColumnWidths to Columns
        For iX = 1 To .ColumnCount
            CW = CW & rData.Columns(iX).Width & ";"
        Next iX
        .ColumnWidths = CW

    End With

    With Me.lbxHeader
        .ColumnCount = Me.lbxData.ColumnCount
        .List = rData.Rows(1).Value
        .ColumnWidths = CW
    End With
End Sub
Private Sub cmdClr_Click()
    ClearAll Me
End Sub

Private Sub cmdUpdate_Click()
    WriteToSheet
End Sub


Private Sub cmdExit_Click()
    Unload Me
End Sub
Sub WriteToSheet()

    If bEdit = True Then
        lRw = rData.Rows.Count + 1
    Else
        lRw = Me.lbxData.ListIndex + 2
    End If

    For iX = 1 To 13
        rData.Cells(lRw, iX).Value = Me("editstudent" & iX).Value
    Next iX

    For iX = 16 To 19
        rData.Cells(lRw, iX).Value = Me("editstudent" & iX - 2).Value
    Next iX

    If bEdit = True Then
        rData.Cells(lRw - 1, "N").Resize(, 2).Copy rData.Cells(lRw, "N")
        rData.Cells(lRw - 1, "Q").Copy rData.Cells(lRw, "Q")
        rData.Cells(lRw - 1, "T").Resize(, 9).Copy rData.Cells(lRw, "T")
    End If
    
    rData.Columns.AutoFit
    ColumnWidths rData

    Me.chkNew.Value = False
    
End Sub
Sub LoadBoxes()
    Me.lblMsg.Caption = "Displaying record #" & lRw + 1 & " of " & rData.Rows.Count - 1 & " records"

    For iX = 0 To 12
        Me("editstudent" & iX + 1).Value = Me.lbxData.List(lRw, iX)
        Me("editstudent" & iX + 1).Font.Size = 10
    Next iX

    For iX = 15 To 18
        Me("editstudent" & iX - 1).Value = Me.lbxData.List(lRw, iX)
        Me("editstudent" & iX - 1).Font.Size = 10
    Next iX


End Sub
Open in new window
Martin Liss
Can you supply a sample workbook?