Страницы: 1
RSS
Поиск строки по артикулу через TextBox
 
Добрый день! Хочу настроить поиск строки по артикулу через TextBox и Кнопку. Подскажите код на кнопку, чтобы при вводе цифр в TextBox искал соответствующую строку
 
смотрите файл
 
Ваш пример работает. А как сделать чтобы целую строчку сравнивал. А то когда вводишь 1 он находит все строчки с единицей, а нужно только одну 1.
Изменено: VB777 - 28.05.2017 12:17:42 (-)
 
Макрос
 
Спасибо огромное за оба кода. Все работает.
 
Тут проблемка в скорости фильтрации. У меня таблица 2008 строк. Можно как нибудь остановить код если проверяемая ячейка пустая. Данные записываются друг за другом. И поэтому после пустой ячейки искать смысла нет.
Вот код который составил Karataev. За что ему огромное спасибо
Код
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = LCase(ActiveSheet.OLEObjects("Textbox1").Object.Text)
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 6 To UBound(arr)
        If LCase(arr(i, 1)) <> strText Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
Изменено: VB777 - 28.05.2017 14:32:25 (-)
 
Вариант с использованием автофильтра:
Макрос

Могу предложить еще такой вариант. Данные будут находиться на одном листе, а TextBox и кнопка на другом. И макрос будет вставлять на лист данные, а не скрывать.
Изменено: Karataev - 28.05.2017 15:00:28
 
Как сделать чтобы после выполнения кода
Код
Sub Поиск()
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = LCase(ActiveSheet.OLEObjects("Textbox1").Object.Text)
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 6 To UBound(arr)
        If LCase(arr(i, 1)) <> strText Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
поднимался на первую найденную позицию. Потому что когда много данных после выполнение кода приходиться роликом подниматься вверх чтобы увидеть найденные данные  
 
Не понятна ситуация. Вы вводите данные в TextBox. Он находится вверху. Затем щелкаете кнопку. Кнопка тоже вверху. После работы макроса так и будет отображаться верх листа.
Вообще, прокрутить экран можно так. Этот код прокручивает так, чтобы была видна ячейка "A1":
Код
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1

Еще способ прокрутки. В этом случае выделяется ячейка "A1" и экран прокручивается так, чтобы отобразить "A1":
Код
Range("A1").Select
Изменено: Karataev - 28.05.2017 17:16:24
 
Я оптимизировал макрос, чтобы макрос работал быстрее. Правильнее сразу все скрыть, а потом отображать нужные, т.к. результат поиска - это, как правило, небольшое количество строк.
Для этого макроса в столбце "B" должен быть текст. Если будут числа, то макрос может неправильно найти последнюю строку.
Макрос
 
ищу макрос поиска со скрытием строк и поиску по части слова в диапазоне таблицы - набрел на эту тему
слепил макрос - вроде все ищет и работает  Только одна заминка - сейчас ищет только в диапазоне arr() = Range("E1:E" & lr).Value
lr = Cells(Rows.Count, "A").End(xlUp).Row
а  как сделать чтобы искал так arr() = Range("A4:M" & lr).Value ?  - но так не прокатывает
те в массив arr() както надо загнать значения диапазона ячеек Range("A4:M" & lr).Value  (а не одного столбца)
макрос рабочий прилагаю
Код
'************************************************************************************
'Макрос ПОИСКА на листе 
'************************************************************************************
Sub ПоискУчетДокументов()
'    Dim strText As String, arr()
    Dim strText As String
    Dim arr() As Variant
    Dim lr As Long, i As Long, x
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    MsgBox lr
    arr() = Range("E1:E" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
            Cells(i, 2).Select
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
загнать-то как раз - нечего делать:
Код
arr() = Range("A4:M" & lr).Value
а вот искать нужно по всему массиву, а не по одной колонке, хотя это то же нечего делать, для тех, кто понимает что там написано
и еще...
совершенно не логично, если не сказать хуже, в комментарии к макросу, который ищет в диапазоне писать "макрос поиска на листе", прочитав надпись можно потом сильно удивляться "что ж он не нашел на листе?, если данные есть"!!!
Изменено: Ігор Гончаренко - 13.07.2019 20:51:02
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
те както If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then переделать ?
 
Код
arr() = Range("A4:M" & lr).Value
For I = LBound(arr, 1) To UBound(arr, 1)    'цикл по 'строка'
    For J = LBound(arr, 2) To UBound(arr, 2) ' цикл по 'столбцам'
        If arr(I, J) = 0 Then
            'какой-то код
        End If
    Next
Next
Согласие есть продукт при полном непротивлении сторон
 
ничего не понял пока - в общем выкладываю файл с примером и код
Код
Sub Поиск()
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr() = Range("B1:B" & lr).Value
    arr() = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Дело в том что при
arr() = Range("B1:B" & lr).Value - все корректно ищет и скрывает строки - но только по столбцу B (а не по всему диапазону A4:M таблицы) - строки со значениями поиска видимы, строки без значений поиска скрыты
При
arr() = Range("A4:M" & lr).Value - все некорректно идет - не работает как надо - нужные строки со значениями поиска скрыты, а строки без значений поиска видимы
 
если использовать вариант от Sanja - то точно такая же ситуация в этом коде - некорректно работает с arr = Range("A4:M" & lr).Value, корректно с arr = Range("B1:B" & lr).Value и по части слова (текста) не работает
Код
Sub Поиск()
Dim strText As String, arr()
    Dim lr As Long, i As Long, j As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr = Range("B1:B" & lr).Value
    arr = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr, 1) 'цикл по строкам
        For j = 1 To UBound(arr, 2) 'цикл по столбцам
            If arr(i, j) = strText Then
            Rows(i).Hidden = False
            Else
            Rows(i).Hidden = True
            End If
        Next
    Next
Application.ScreenUpdating = True
End Sub
Изменено: andreyka33 - 14.07.2019 09:25:22
 
когда начнете использовать код, как написал Sanja, тогда скажете что не работает код от Sanja, а пока код пишете Вы не понимая толком что там пишете, очевидно что бестолковый код не должен работать, может начать работать только благодаря какой-то счастливой случайности
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
С find работает ниже код нормально - но предполагается что в таблице будет 2-3 тыс строк - наверно тупить будет
Поэтому вопрос выше с массивами актуален - как же его переделать чтоб корректно работал ?
Код
Sub ПоискУчетДокументов()
Dim lr As Long, x
Dim ra As Range, ТекстДляПоиска As String
Application.ScreenUpdating = False

    Rows.Hidden = False
    ТекстДляПоиска = ActiveSheet.OLEObjects("Textbox1").Object.Text ' показываем строки с таким текстом
    If ТекстДляПоиска = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.Range("A4:M" & lr).Rows
        ' если в строке найден искомый текст
    If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
        ra.EntireRow.Hidden = False 'показываем строки
        Else 'иначе
        ra.EntireRow.Hidden = True 'скрываем строки
    End If
    Next
    
    
Application.ScreenUpdating = True
End Sub
 
Цитата
andreyka33 написал:
как же его переделать чтоб корректно работал ?
как бы в вопросе уже есть ответ: переделывайте до тех пор пока он не начнет корректно работать
если хотите, чтобы кто-то Вам помог - обьясните задачу, приложите файл с данными или рекомендация выше - переделывать самостоятельно пока не заработает как нужно
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
дак я файл пример приложил выше и все написал - еще раз
Дело в том что при
arr() = Range("B1:B" & lr).Value - все  корректно ищет и скрывает строки - но только по столбцу B (а не по всему  диапазону A4:M таблицы) - строки со значениями поиска видимы, строки  без значений поиска скрыты
При
arr() = Range("A4:M" &  lr).Value - все некорректно идет - не работает как надо - нужные строки  со значениями поиска скрыты, а строки без значений поиска видимы
Код
Sub Поиск()
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr() = Range("B1:B" & lr).Value
    arr() = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
я расспрашиваю Вас не о макросах, которые Вы написали, а о задаче которую решаете
в чем задача?
Изменено: Ігор Гончаренко - 14.07.2019 14:46:02
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Задача- поиск в диапазоне Range("A4:M" & lr).Value путем скрытия строк - если в строке в ячейках диапазона нет значения поиска.Если в строке есть значение поиска по частичному совпадению - то строка остается видимой, если нет то скрывается строка). Тк таблица будет большой под 2-3 тыс записей  (будет пополнятся постоянно) лучше сделать через массив - что и пытаюсь сделать. Пример выше.
 
Код
Sub Ïîèñê()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, c&, Fnd As Boolean
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    arr() = Range("A1:M" & lr).Value
    For i = 4 To UBound(arr)
      Fnd = False
      For c = 1 To UBound(arr, 2)
        If InStr(1, arr(i, c), strText, vbTextCompare) > 0 Then Fnd = True: Exit For
      Next
      Rows(i).Hidden = Not Fnd
    Next i
    Application.ScreenUpdating = True
End Su
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Код
Option Explicit
Option Compare Text

Sub Поиск()
Dim strText$, arr()
Dim lRow&, I&, J&
Dim hRows As Range
Application.ScreenUpdating = False
Rows.EntireRow.Hidden = False
lRow = Cells(Rows.Count, "A").End(xlUp).Row
With Range("A4:M" & lRow)
    arr = .Value
    .EntireRow.Hidden = True
End With
strText = ActiveSheet.TextBox1.Text
If strText <> "" Then
    For I = LBound(arr) To UBound(arr)
        For J = LBound(arr, 2) To UBound(arr, 2)
            If arr(I, J) Like "*" & strText & "*" Then
                If Not hRows Is Nothing Then
                    Set hRows = Union(hRows, Rows(I + 3))
                Else
                    Set hRows = Rows(I + 3)
                End If
            End If
        Next
    Next
    If Not hRows Is Nothing Then
        hRows.EntireRow.Hidden = False
    Else
        Rows.Hidden = False
    End If
End If
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Благодарю Ігор Гончаренко и Sanja - за то что помогли !
Проверил - макрос Игоря работает нормально, а вот макрос Sanja к сожалению не заработал как надо.

Файл с обоими макросами во вложении
 
Я исправил макрос выше
Согласие есть продукт при полном непротивлении сторон
 
Еще раз благодарю
3 варианта получается во вложении
Страницы: 1
Наверх