Страницы: 1
RSS
Поиск в выпадающем списке с выводом двух значений
 
Здравствуйте помогите сделать поиск в выпадающем списке с выводом двух значений? В прилагаемом примере поиск осуществляется по одному списку взяты с определенного столбца "A:A" и безв повторяющегося значения. А нужно чтобы он выводил в одном окне весь список из столбца "A:A", а во втором окне весь список из столбца "B:B". Например надо найти "Метан", ввожу его и нужно чтобы в первом оне вышли все варианты "Метан" из столбца "A", а во втором окне список из столбца "B" варианты которые расположены на против их, то есть например "A10" соответствует "B10"
 
Добрый день.
У нас нет Вашей надстройки ПДВ3 надстройка.xlam'!MyStartFindInDropList
Код то есть в этом файле, а вот настройки и списки неведомы, а может она там уже и какая другая... Два окна каких-то упоминаете.
Изменено: Hugo - 21.07.2020 17:26:03
 
Извините, вот файл
Изменено: Lerik2020 - 21.07.2020 17:41:39
 
Я пас,тут вроде много работы, неохота. Зато честно :) (с)
 
Так надо? Код для события  ListBoxItems_Click

Код
Private Sub ListBoxItems_Click()
Dim arr, i As Long, MainValue As String

    If Me.ListBoxItems.ListCount = 0 Then Exit Sub
    arr = Worksheets("Список").Range("A1").CurrentRegion.Value
    For i = 0 To Me.ListBoxItems.ListCount - 1
        If Me.ListBoxItems.Selected(i) Then
            MainValue = Me.ListBoxItems.List(i)
            Exit For
        End If
    Next
    If MainValue = "" Then Exit Sub
    Me.ListBox1.Clear
    For i = 1 To UBound(arr)
        If arr(i, 1) = MainValue Then Me.ListBox1.AddItem arr(i, 2)
    Next i
End Sub
Изменено: New - 21.07.2020 19:47:40
 
Да то что нужно, спасибо огромнейшее!!! Подскажите, а как сделать чтобы он еще в ячейку вставлял???
 
Если честно, то странные вы вопросы задаёте, если смотреть код вашего файла) Там куча кода и довольно сложного, а вы какие-то детские вопросы задаёте)
Это не ваш код в файле?
Смотрите, вот примеры вставки кода в ячейку:
[A1] = "мама"
Range("A1") = "мама"
Cells(1, 2) = "мама", где 1 это номер строки, а 2 это номер столбца

Если честно, то не понятно что и в какую ячейку вставлять
 
Странное понятие у Вас о детских вопросах, вы не по адресу. Я разобрался. Вот код может кому надо будет.
Код
Option Explicit
Option Compare Text

Private Sub Comm1_Click()
    Dim r As Integer, C As Integer
    If ListBox1.ListIndex = -1 Then Exit Sub
    If Not ActiveSheet Is iSheetLists Then
        If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
            MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
        Else
            ActiveCell.Value = ListBox1.Text
            Select Case iShiftOption
            Case 0: r = 0: C = 0
            Case 1: r = -1: C = 0
            Case 2: r = 0: C = 1
            Case 4: r = 0: C = -1
            Case Else: r = 1: C = 0
            End Select
            On Error Resume Next
            'AppActivate "Microsoft Excel"
            ActiveCell.Offset(r, C).Activate
            ListBox1.SetFocus
            On Error GoTo 0
        End If
    End If
End Sub

Private Sub HelpButton_Click()
    Me.Hide
    With HelpForm
        .Top = Me.Top
        .Left = Me.Left
        .Show
    End With
    Me.Show
End Sub

Private Sub ListBox1_Click()
    Call MyControlsState(Not ListBox1.ListIndex = -1)
    NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub

Private Sub ListBoxItems_Click()
Dim arr, i As Long, MainValue As String
 
    If Me.ListBoxItems.ListCount = 0 Then Exit Sub
    arr = Worksheets("Список").Range("A1").CurrentRegion.Value
    For i = 0 To Me.ListBoxItems.ListCount - 1
        If Me.ListBoxItems.Selected(i) Then
            MainValue = Me.ListBoxItems.List(i)
            Exit For
        End If
    Next
    If MainValue = "" Then Exit Sub
    Me.ListBox1.Clear
    For i = 1 To UBound(arr)
        If arr(i, 1) = MainValue Then Me.ListBox1.AddItem arr(i, 2)
    Next i
End Sub

'----------------------------------------------------------
'----------------------------------------------------------

Private Sub UserForm_Initialize()
    Me.Tag = 1
    Me.Caption = AppName
    If iMainFormPosOption = 1 Then Call mySetFormKoord(Me)    ' устанавливаем координаты формы
    Call AssigningValuesToVariables    ' присваиваем значения переменным
    Call MyFillDataControlLists(ComboBoxLists)    ' заполняем данными комбобокс с названиями списков и устанавливаем в нем текущий єлемент.
    If dLists.Count = 0 Then
        MsgBox "Нет списков для выбора!" & vbCrLf & "Для продолжения работы добавьте хотя бы один список." _
               , vbExclamation + vbOKOnly, AppName
        SettingsForm.Show
        Call MyFillDataControlLists(ComboBoxLists)
    End If
End Sub

Private Sub AssigningValuesToVariables()
    Call myGetCustomProperties("NumListColumn", 1, iNumListColumn)
    Call myGetCustomProperties("SortingOption", 1, iSortingOption)
    Call myGetCustomProperties("ShiftOption", 3, iShiftOption)
    Call myGetCustomProperties("DblClickRunOption", 1, iDblClickRunOption)
    Call myGetCustomProperties("FindOption", 1, iFindOption)
    Call myGetCustomProperties("MainFormPosOption", 1, iMainFormPosOption)
End Sub

Private Sub myGetCustomProperties(prName As String, prValueDefault As Long, prValue As Long)
    On Error Resume Next
    With ThisWorkbook.CustomDocumentProperties
        If Not MyCustomPropertiesExists(prName) Then _
           Call MyCreateCustomProperties(prName, prValueDefault)
        prValue = CLng(.Item(prName))
        If Not Err.Number = 0 Then prValue = prValueDefault
    End With
    On Error GoTo 0
End Sub

Private Sub ComboBoxLists_Change()
    Dim s
    TextBoxItems.Text = ""
    ListBoxItems.Clear
    If ComboBoxLists.Text = "" Then Exit Sub
    s = ComboBoxLists.Text
    If IsNumeric(s) Then s = Val(s)
    iNumListColumn = dLists.Item(s)
    Call MyFillDataControlItems(ListBoxItems)
End Sub

Private Sub ListBoxItems_Change()
    Call MyControlsState(Not ListBoxItems.ListIndex = -1)
    NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub
Private Sub MyControlsState(ContrlState As Boolean)
    OKButton.Enabled = ContrlState
    DelItButton.Enabled = ContrlState
    NewItButton.Enabled = ContrlState
End Sub
Private Sub MyControlsState22(ContrlState As Boolean)
    Comm1.Enabled = ContrlState
    DelItButton.Enabled = ContrlState22
    NewItButton.Enabled = ContrlState22
End Sub
Private Sub TextBoxItems_Change()
    Dim s As String, it
    NewItButton.Enabled = Not TextBoxItems.Text = ""
    If ComboBoxLists.Text = "" Or _
       dLists.Count = 0 Then NewItButton.Enabled = False: Exit Sub
    If dItems.Count = 0 Then Exit Sub
    ListBoxItems.Clear
    If TextBoxItems.Text = "" Then
        ListBoxItems.List = dItems.keys
    Else
        s = "*" & TextBoxItems.Text & "*"
        If iFindOption = 2 Then s = Mid(s, 2)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For Each it In dItems.keys
                If it Like s Then .Item(it) = ""
            Next it
            If .Count = 0 Then Exit Sub
            ListBoxItems.List = .keys
        End With
    End If
    ListBoxItems.ListIndex = 0
End Sub

Private Sub CancelButton_Click()
    Unload Me
End Sub

Private Sub ComboBoxLists_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub

Private Sub DelItButton_Click()
    Dim r As Range
    If MsgBox("Вы действительно хотите удалить" & vbCrLf & "элемент: " & _
              ListBoxItems.Text & vbCrLf & "из списка: " & ComboBoxLists.Text & " ?", vbOKCancel + vbExclamation, _
              "Удаление элемента списка") = vbOK Then
        With iSheetLists.Columns(iNumListColumn)
            On Error Resume Next
            Set r = .Find(What:=ListBoxItems.Text, LookIn:=xlValues, LookAt:=xlWhole)
            If Not r Is Nothing Then r.Delete Shift:=xlUp
        End With
        dItems.RemoveAll
        TextBoxItems.Text = ""
        Call MyFillDataControlItems(ListBoxItems)
    End If
End Sub

Private Sub ListBoxItems_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call OKButton_Click
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call Comm1_Click
End Sub
Private Sub NewItButton_Click()
    Dim s
    s = TextBoxItems.Text
    If IsNumeric(s) Then s = Val(s)
    If Len(Trim(s)) = 0 Then Exit Sub
    If dItems.Exists(s) Then
        MsgBox "Элемент: " & s & vbCrLf & "уже есть в этом списке !"
        Exit Sub
    End If
    With iSheetLists
        On Error Resume Next
        .Cells(.Rows.Count, iNumListColumn).End(xlUp).Offset(1, 0).Value = s
    End With
    dItems.RemoveAll
    TextBoxItems.Text = ""
    Call MyFillDataControlItems(ListBoxItems, s)
End Sub

Private Sub OKButton_Click()
    Dim r As Integer, C As Integer
    If ListBoxItems.ListIndex = -1 Then Exit Sub
    If Not ActiveSheet Is iSheetLists Then
        If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
            MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
        Else
            ActiveCell.Value = ListBoxItems.Text
            Select Case iShiftOption
            Case 0: r = 0: C = 0
            Case 1: r = -1: C = 0
            Case 2: r = 0: C = 1
            Case 4: r = 0: C = -1
            Case Else: r = 1: C = 0
            End Select
            On Error Resume Next
            'AppActivate "Microsoft Excel"
            ActiveCell.Offset(r, C).Activate
            ListBoxItems.SetFocus
            On Error GoTo 0
        End If
    End If
End Sub

Private Sub SettingsButton_Click()
    Call MyControlsState(False)
    Me.Hide
    SettingsForm.Show
    ListBoxItems.Clear
    Call MyFillDataControlLists(ComboBoxLists)
    If Not dLists.Count = 0 Then
        Call MyFillDataControlItems(ListBoxItems)
    End If
    TextBoxItems.Text = ""
    Me.Show 0
End Sub

Private Sub UserForm_Terminate()
    Call mySetCustomProperties("NumListColumn", iNumListColumn)
    Call mySetCustomProperties("SortingOption", iSortingOption)
    Call mySetCustomProperties("ShiftOption", iShiftOption)
    Call mySetCustomProperties("DblClickRunOption", iDblClickRunOption)
    Call mySetCustomProperties("FindOption", iFindOption)
    Call mySetCustomProperties("MainFormPosOption", iMainFormPosOption)

    Set dLists = Nothing
    Set dItems = Nothing
 
End Sub

Private Sub mySetCustomProperties(prName As String, prValue As Long)
    On Error Resume Next
    With ThisWorkbook.CustomDocumentProperties
        If MyCustomPropertiesExists(prName) Then
            .Item(prName).Value = prValue
        Else
            Call MyCreateCustomProperties(prName, prValue)
        End If
    End With
    On Error GoTo 0
End Sub
Изменено: Lerik2020 - 22.07.2020 00:03:55
 
Всем здравствуйте. Подскажите, а если создам еще один список, который будет находиться на другом листе, назовем лист "Тетради"  что нужно добавить в
Цитата
New написал:
Код для события  ListBoxItems_Click
чтобы он осуществлял еще поиск и на нём?
 
Подниму тему вверх, может быть кто знает решение
 
Lerik2020, здравствуйте
Может подойдёт Форма с поиском по маске. Как найти и получить одно или несколько значений
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous Здравствуйте, не подойдет
 
Прикольная тема.
Вопрос к Модераторам, стоит ли создавать тему, по такому же вопросу, как сделать чтобы списки можно было создавать на других листа, и чтобы работало по такому же принципу???
 
Если разница только в расположении  списка, то новая тема не нужна
 
Вроде бы как я понял. Вот это часть кода отвечает за поиск в окне "ListBox1"
Код
Private Sub ListBoxItems_Click()
Dim arr, i As Long, MainValue As String
 
    If Me.ListBoxItems.ListCount = 0 Then Exit Sub
    arr = Worksheets("Список").Range("A1").CurrentRegion.Value
    For i = 0 To Me.ListBoxItems.ListCount - 1
        If Me.ListBoxItems.Selected(i) Then
            MainValue = Me.ListBoxItems.List(i)
            Exit For
        End If
    Next
    If MainValue = "" Then Exit Sub
    Me.ListBox1.Clear
    For i = 1 To UBound(arr)
        If arr(i, 1) = MainValue Then Me.ListBox1.AddItem arr(i, 2)
    Next i
End Sub
что сюда можно добавить, если не находит на листе "Список", продолжать поиск на другом листе "Товар"
Изменено: Deniska3 - 30.11.2020 14:16:09
Страницы: 1
Наверх