Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 35704
Главная » Готовые решения » VBA » Полезные приёмы

Поиск значений в базе данных по первым буквам при вводе на листе (как в 1С)
21.09.2013, 16:40
[ Файл-пример (191.3Kb) ]

Предположим, на листе есть большая база данных. Поиск по базе можно организовать с помощью поля (текстбокс) для ввода интересующего значения и обновляющегося по мере ввода списка (листбокс) подходящих значений:

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

Можно также использовать форму (см. файл-пример)

Добавил: nilem |
Просмотров: 15061 | Рейтинг: 5.0/7
Всего комментариев: 26
0   Спам
1    sashagerych   (06.02.2014 16:36)
   ОЧЕЙНЬ полезная вещь!!! hands
Подскажите как расширить диапазон поиска ? В идеале хотелось бы сделать такой поиск по всей книге.

+3   Спам
2    nilem   (07.02.2014 09:06)
   Sashagerych, набросайте какой-нибудь примерчик для поиска по книге. На форуме попробуем порешать, и, если получится что-то стоящее, положим сюда. :)

0   Спам
3    sashagerych   (07.02.2014 14:22)
   Так и сделаю :)
Правда сам я в VBA только на пальцах считать умею, так что могу сделать примитивный примерчик с пояснениями как я это вижу :)

0   Спам
4    buskopan   (10.08.2014 18:37)
   Отличная вещь. А можно сделать так чтобы после того как курсор мыши убирался, поиск удалял содержимое из окошка ? Спасибо

+1  
5    Serge_007   (10.08.2014 18:47)
   Можно
Например используйте событие MouseMove

0   Спам
6    buskopan   (10.08.2014 19:53)
   Я и макрос то запустить не могу. Выдает object required на строке If ListBox1.ListIndex

0  
7    Serge_007   (10.08.2014 20:02)
   А ListBox1 в файле есть?

0   Спам
8    buskopan   (10.08.2014 20:12)
   это название листа или обьект некий ? может где есть описание как применить данный макрос к книге ?

0  
9    Serge_007   (10.08.2014 20:21)
   А файл скачать Вы не пробовали? это же ГОТОВОЕ РЕШЕНИЕ!

0   Спам
10    buskopan   (10.08.2014 20:32)
   разобрался. спасибо ) Теперь надо с событием MouseMoe разобраться

0  
11    Serge_007   (25.08.2014 23:11)
   Николай, отличное решение, спасибо!

На работе всем сотрудникам его внедрил, теперь они пищат от восторга :)

0   Спам
12    nilem   (25.08.2014 23:37)
   Заменил файл-пример: на 3-м листе есть разновидность поиска с встроенными полем и списком.
Кстати, если есть желание, давайте попробуем сделать красивую надстройку? (понадобятся пожелания/хотелки и время для тестирования)

0  
13    Serge_007   (25.08.2014 23:52)
   Я готов :)

0   Спам
14    nilem   (26.08.2014 00:28)
   Ок, давайте хотелки :), и... где будем общаться?

0  
15    Serge_007   (26.08.2014 00:32)
   Да прям тут :)

0   Спам
16    Re:Я   (17.09.2014 10:26)
   Доброго времени суток.
действительно хорошая вещь. Для своей работы мне пригодиться Sheet1 и ENTRY
Есть вопросы, на которые очень прошу ответить.
1. Для Sheet1 где поменять номер столбца? Например у меня необходимо брать данные из столбца 5 или Е.
2.Для ENTRY мне не нужно заполнять массив, а просто в ячейке ввести первые буквы, поиск должен выдать варианты.
С ёкселем чуть-чуть дружу, а вот с макросами, ни как не получается.
Если необходимо, могу скинуть свой файл.
Заранее благодарен.

0   Спам
17    nilem   (18.09.2014 20:47)
   Здрасьте. По п.1 вместо
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value
напишите
x = Range("E1", Cells(Rows.Count, 5).End(xlUp)).Value

А в Sub ListBox1_Click() вместо
Columns(1).Find(ListBox1, lookat:=xlWhole).Select
нужно будет
Columns(5).Find(ListBox1, lookat:=xlWhole).Select

По п.2 не очень понятно. Наверное, лучше задать вопрос на форуме. Здесь ведь только "приемчики", а реализация м.б. какой угодно.

0   Спам
18    A_S_P   (19.10.2014 15:17)
   Добрый день! Гуру не подскажут как сделать так, чтобы поиск был не по первым буквам, а по любым в строке. Например есть ячейка с текстом 0,75ВИНО ВАЛЛЕФЬОРИ РОСС КР СХ, и мне надо ее найти по слову вино или слову валл

0   Спам
19    udarock   (03.11.2014 02:56)
   Здравствуйте!
Очень интересный код,
интересует как можно его переделать так, чтобы можно было сделать следующее:
Есть база данных (предположим на диапазоне ячеек А2:B7)
Я хочу производить поиск по диапазону А2:А7, но при выборе выводить значения из диапазона В2:В7
Так же поисковую форму я хочу, например, поставить на ячейки в диапазоне F2:F4 и G8:G10, а выводить значения в диапазон ячеек K2:K4 и K8:K10 соответственно
Я знаю, что можно эту задачу решить используя элементы ActiveX, но хотелось бы это сделать с помощью данного кода, самому опыта не хватает переделать ваш код, такое можно сделать?
Заранее спасибо

0   Спам
20    Staniiislav   (29.12.2014 23:08)
   Доброго времени суток. Подскажите пожалуйста, каким образом можно производить поиск по нескольким столбцам массива и выводить результат тоже из нескольких столбцов, а не с одного?

+1   Спам
21    nilem   (02.01.2015 07:43)
   Привет, Станислав
попробуйте так
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

0   Спам
22    Staniiislav   (03.01.2015 14:01)
   Спасибо 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 работают быстрее

0   Спам
23    nilem   (04.01.2015 19:17)
   Лучше бы, конечно, на форуме это обсудить, чтобы не загромождать "приемчик"

0   Спам
24    Jester   (13.04.2015 11:52)
   Доброго времени суток. Подскажите пожалуйста как изменить код в листе ENTRY для ввода данных с другого листа. Спасибо.

0   Спам
25    Ант77   (07.12.2015 14:06)
   Добрый день, может кто помочь где я что не так делаю
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

никак не могу заставить работать

0   Спам
26    Ант77   (07.12.2015 14:57)
   Спасибо, разобрался, только как данные с другого листа брать пока не понимаю.

Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!