Страницы: 1
RSS
Поиск значений в столбце с указанием строк, в которых они найдены
 
Здравствуйте! Прошу помочь с доработкой кода. Данный код ищет заданные слова в столбце, выделяет совпадения жирным и окрашивает красным. Вместо выделения совпадений, мне необходимо указывать номера строк, в которых они находятся. Перечень номеров строк необходимо вывести в Workbooks("7.0.xlsb").Sheets("Спер") в столбец А. Большое спасибо!
Код
Sub Find_n_Highlight()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$, v, pos&
    res = Workbooks("7.0.xlsb").Sheets("Сдан").Range("C2")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов    
    Set ra = Workbooks("Сеть7.xlsb").Sheets("Срас").Range([P2], Range("P" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    ra.Font.Color = 0: ra.Font.Bold = 0  ' сброс цветового выделения    
    For Each cell In ra.Cells    ' перебираем все ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
            If UBound(arr) > 0 Then    ' если подстрока найдена
                For Each v In arr    ' перебираем все вхождения
                    pos = pos + Len(v)    ' начальная позиция
                    With cell.Characters(pos, Len(txt))
                        .Font.ColorIndex = 3    ' выделяем цветом
                        .Font.Bold = True    ' и полужирным начертанием
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell
End Sub
Изменено: Platon - 04.04.2018 14:48:54
 
Проверяйте
Код
Sub Find_n_Highlight()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$
    res = Workbooks("7.0.xlsb").Sheets("Сдан").Range("C2")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов
    Set ra = Workbooks("Сеть7.xlsb").Sheets("Срас").Range([P2], Range("P" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    lRow = 1
    For Each cell In ra.Cells    ' перебираем все ячейки
        If cell.Text Like "*" & txt & "*" Then
            Workbooks("7.0.xlsb").Sheets("Спер").Range("A" & lRow) = cell.Row
            lRow = lRow + 1
            End With
        End If
    Next cell
End Sub
Изменено: Sanja - 04.04.2018 16:11:50
Согласие есть продукт при полном непротивлении сторон
 
Спасибо!
Лишь строка
End With
оказалась лишней.
Если код кому-то понадобится, то в данном случае для запуска макроса требуется активировать окно "Сеть7.xlsb".
Еще раз спасибо!
Страницы: 1
Наверх