Страницы: 1
RSS
Нестрогий поиск - не учитывать спецсимволы и пробелы
 
День добрый всем !

Есть макрос поиска по InStr- нашел на просторах инета приспособил под свои нужды
По значению TextBox1 ищет совпадающие значения в столбце B и показывает нужные строки с совпадающими значениями (остальные скрывает)
Код
Sub Поиск ()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, x
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.text
    If strText = "" Then
        Exit Sub
    End If
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & 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
        End If
    Next i
    
    x = dhCountVisibleCells(Range("A5:S500"))
    If x = 0 Then
    Rows.EntireRow.Hidden = False
    MsgBox "Текст не найден !"
    Else
'    ActiveWindow.ScrollColumn = 8
    End If
End Sub

Вопрос в том что нужно сделать нестрогий поиск - исключить спецсимволы (кавычки, точки, тире и пр) и лишние пробелы (не дожны учитываться при поиске)
те както модифицировать строку
Код
If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then

чтоб не учитывал при поиске регистр,спецсимволы и лишние пробелы ?
Например: в TextBox1 строка для поиска:  Шкаф     Белый
найдет  шкаф "белый"
 
Replace в помощь. В цикле убираете из сравниваемой строки все лишнее. Вроде того:
Код
Function DelTrash(s$)
    Dim aToFind, li&, res$
    aToFind = Array(Chr(34), " ", ".", ",", "'", "\") 'Chr(34) = кавычка
    res = s
    For li = LBound(aToFind) To UBound(aToFind)
        res = Replace(res, aToFind(li), "")
    Next
    DelTrash = res
End Function

обе сравниваемые строки обрабатываете такой функцией и сравниваете.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Благодарю - буду пробовать отпишусь как результат
 
Так сделал  - но ошибку дает на строке arr(i, 1) = DelTrash(arr(i, 1))  типа  ByRef argument type mismatch
Код
Function DelTrash(s$)
    Dim aToFind, li&, res$
    aToFind = Array(Chr(34), " ", ".", ",", "'", "\") 'Chr(34) = кавычка
    res = s
    For li = LBound(aToFind) To UBound(aToFind)
        res = Replace(res, aToFind(li), "")
    Next
    DelTrash = res
End Function


Sub Поиск ()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, x
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.text
    If strText = "" Then
        Exit Sub
    End If
   strText = DelTrash(strText)
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 4 To UBound(arr)
       arr(i, 1) = DelTrash(arr(i, 1))
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
        End If
    Next i
     
    x = dhCountVisibleCells(Range("A5:S500"))
    If x = 0 Then
    Rows.EntireRow.Hidden = False
    MsgBox "Текст не найден !"
    Else
'    ActiveWindow.ScrollColumn = 8
    End If
End Sub
 
Так надо было хотя бы попытаться перевести текст ошибки :) Несовпадение типов. У Вас arr - тип Variant, а моя функция требует текст. Передавайте так:
Код
arr(i, 1) = DelTrash(arr(i, 1) & "")
можно и через CStr, но кто знает что там у Вас в arr - вдруг там Null откуда-то возьмется...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий все заработало - еще раз благодарю за помощь!
Страницы: 1
Наверх