Предположим, на листе есть большая база данных. Поиск по базе можно организовать с помощью поля (текстбокс) для ввода интересующего значения и обновляющегося по мере ввода списка (листбокс) подходящих значений:
Option Compare Text
Private Sub TextBox1_Change()
Dim x, i As Long, txt As String, lt As Long, s As String
txt = TextBox1.Text: lt = Len(TextBox1.Text)
If lt = 0 Then Exit Sub
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(x, 1) ' поиск по первым буквам
If txt = Mid(x(i, 1), 1, lt) Then s = s & "~" & x(i, 1)
Next i
'For i = 1 To UBound(x, 1) 'поиск по любому вхождению
' If InStr(x(i, 1), txt) Then s = s & "~" & x(i, 1)
'Next i
ListBox1.List = Split(Mid(s, 2), "~")
End Sub
Private Sub ListBox1_Click()
If ListBox1.ListIndex = -1 Then Exit Sub
Columns(1).Find(ListBox1, lookat:=xlWhole).Select
End Sub
Заменил файл-пример: на 3-м листе есть разновидность поиска с встроенными полем и списком. Кстати, если есть желание, давайте попробуем сделать красивую надстройку? (понадобятся пожелания/хотелки и время для тестирования)
Доброго времени суток. действительно хорошая вещь. Для своей работы мне пригодиться Sheet1 и ENTRY Есть вопросы, на которые очень прошу ответить. 1. Для Sheet1 где поменять номер столбца? Например у меня необходимо брать данные из столбца 5 или Е. 2.Для ENTRY мне не нужно заполнять массив, а просто в ячейке ввести первые буквы, поиск должен выдать варианты. С ёкселем чуть-чуть дружу, а вот с макросами, ни как не получается. Если необходимо, могу скинуть свой файл. Заранее благодарен.
Добрый день! Гуру не подскажут как сделать так, чтобы поиск был не по первым буквам, а по любым в строке. Например есть ячейка с текстом 0,75ВИНО ВАЛЛЕФЬОРИ РОСС КР СХ, и мне надо ее найти по слову вино или слову валл
Здравствуйте! Очень интересный код, интересует как можно его переделать так, чтобы можно было сделать следующее: Есть база данных (предположим на диапазоне ячеек А2:B7) Я хочу производить поиск по диапазону А2:А7, но при выборе выводить значения из диапазона В2:В7 Так же поисковую форму я хочу, например, поставить на ячейки в диапазоне F2:F4 и G8:G10, а выводить значения в диапазон ячеек K2:K4 и K8:K10 соответственно Я знаю, что можно эту задачу решить используя элементы ActiveX, но хотелось бы это сделать с помощью данного кода, самому опыта не хватает переделать ваш код, такое можно сделать? Заранее спасибо
Доброго времени суток. Подскажите пожалуйста, каким образом можно производить поиск по нескольким столбцам массива и выводить результат тоже из нескольких столбцов, а не с одного?
Привет, Станислав попробуйте так Private Sub TextBox1_Change() Dim x, v, txt As String, lt As Long, s As String txt = TextBox1.Text: lt = Len(TextBox1.Text) If lt = 0 Then Exit Sub ' будем искать в столбцах A:D x = Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value For Each v In x ' поиск по первым буквам If txt = Mid(v, 1, lt) Then s = s & "~" & v Next i 'For Each v In x 'поиск по любому вхождению ' If InStr(v, txt) Then s = s & "~" & v 'Next i ListBox1.List = Split(Mid(s, 2), "~") End Sub
Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Range("A:D").Find(ListBox1, lookat:=xlWhole).Select End Sub
Спасибо nilem! Но не совсем получается. ListBox находиться в UserForm, и данные я вывожу на несколько колонок ListBox1.ColumnCount = 11 ListBox1.ColumnWidths = "50;40;140;140;140;140;40;40;40;40;40"
А макрос у меня сейчас работает так:
Private Sub TextBox1_Change() Dim txt$, i&, j&, ii&, n&, xx txt = TextBox1.Text ii = 1 With ListBox1 .Clear If Len(txt) = 0 Then .List = x: Exit Sub ReDim xx(1 To UBound(x, 1), 1 To UBound(x, 2)) For i = 1 To UBound(x) For j = 2 To 6 If InStr(1, x(i, j), txt) Then xx(ii, 1) = x(i, 1) xx(ii, 2) = x(i, 2) xx(ii, 3) = x(i, 3) xx(ii, 4) = x(i, 4) xx(ii, 5) = x(i, 5) xx(ii, 6) = x(i, 6) xx(ii, 7) = x(i, 7) xx(ii, 8) = x(i, 8) xx(ii, 9) = x(i, 9) xx(ii, 10) = x(i, 10) xx(ii, 11) = x(i, 11) ii = ii + 1 Exit For End If Next j Next i .List = xx For i = .ListCount - 1 To 0 Step -1 If .List(i, 0) = 0 Then .RemoveItem i Next End With End Sub
Работает довольно быстро (Вы как-то давали пример данного поиска). Но просто для эксперимента пытался сделать быстрее взял из этой статьи пример nerv и сделал поиск:
Private Sub TextBox1_Change() Dim txt$, t Dim ADO As New ADO Dim Arr As Variant t = Timer txt = TextBox1.Text With ListBox1 .Clear If Len(txt) = 0 Then .List = x: Exit Sub ADO.Query ("SELECT F1, F2, F3, F4, F5, F6, F7, F8 " _ & "FROM [Где_Искать$A2:H] " _ & "WHERE " _ & "F1 LIKE " & "'%" & txt & "%'" _ & " Or F2 LIKE " & "'%" & txt & "%'" _ & " Or F3 LIKE " & "'%" & txt & "%'" _ & " Or F4 LIKE " & "'%" & txt & "%'" _ & " Or F5 LIKE " & "'%" & txt & "%'" _ & " Or F6 LIKE " & "'%" & txt & "%'" _ & " Or F7 LIKE " & "'%" & txt & "%'" _ & " Or F8 LIKE " & "'%" & txt & "%'" _ )
Arr = ADO.ToArray() If IsEmpty(Arr) Then .Clear Else .List = Arr End If End With Debug.Print Timer - t End Sub
Работает, но все же стандартными функции VBA работают быстрее
Добрый день, может кто помочь где я что не так делаю Option Explicit Option Compare Text Dim bu As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.CountLarge > 1 Then Exit Sub If Target.Row = 1 Then Me.TextBox1.Visible = False: Me.ListBox1.Visible = False: Exit Sub If Target.Column = 2 Then bu = True With Me.TextBox1 .Top = Target.Top: .Text = Target.Value ': .Activate End With With Me.ListBox1 .Top = Target.Top + 5 If (.Top + .Height + ActiveWindow.PointsToScreenPixelsY(0) * Application.InchesToPoints(1) * 15 / 1440) > _ (ActiveWindow.Application.Height + ActiveWindow.Application.Top) Then _ .Top = .Top - .Height + Target.Height '* ActiveWindow.Zoom / 100 .Clear End With bu = False Me.TextBox1.Visible = True: Me.ListBox1.Visible = True Else Me.TextBox1.Visible = False: Me.ListBox1.Visible = False End If End Sub
Private Sub TextBox1_Change() If Len(TextBox1.Text) = 0 Or bu Then Exit Sub 'при отсутствии символов для поиска - выход Dim x, i As Long, txt As String, lt As Long, s As String txt = TextBox1.Text: lt = Len(TextBox1.Text) x = Columns(32).SpecialCells(2).Offset(1).Value For i = 1 To UBound(x, 1) ' поиск по первым буквам If txt = Mid(x(i, 1), 1, lt) Then s = s & x(i, 1) & "~" Next i ListBox1.List = Split(s, "~") End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Or KeyCode = 9 Then With Me.TextBox1 ActiveCell.Value = .Value .Visible = False: ListBox1.Visible = False End With ActiveCell(2, 1).Select End If End Sub
Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Application.EnableEvents = False bu = True With Me.ListBox1 ActiveCell.Value = .Value Me.TextBox1.Text = .Value Me.TextBox1.Visible = False: .Visible = False End With
Application.EnableEvents = True bu = False End Sub
'Sub tt() 'Application.EnableEvents = True 'End Sub