Здравствуйте! Прошу помочь с доработкой кода. Данный код ищет заданные слова в столбце, выделяет совпадения жирным и окрашивает красным. Вместо выделения совпадений, мне необходимо указывать номера строк, в которых они находятся. Перечень номеров строк необходимо вывести в 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 Subcode]
Здравствуйте,
Sub Find_n_Highlight()
End Sub
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 ' сброс цветового выделения
Dim i&: i = 1
For Each cell In ra.Cells ' перебираем все ячейки
pos = 1
If cell.Text Like "*" & txt & "*" Then
Workbooks("7.0.xlsb").Sheets("Спер").Cells(i, 1).Value = cell.Row
i = i + 1
' 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