Здравствуйте. Есть вот такое задание: 1. Есть код, организовать поиск введённого кода по таблице 2. Сначала: на полное совпадение затем на совпадение первых 4-х символов на совпадение последних 4-х символов далее поиск с заменой схожих символом : B - 8, D - 0, g - 9, G - 6 , I - 1, i -1, l - 1, O - 0, s - 5, S - 5, поиск производиться с постепенной подменой символов(лестницей) + коминация этих символов
сам код находиться в столбце Х (Serial_Number) сам фаил с таблицами Ссылка удалена администрацией
С поиском и выделением вроде справиося
Sub Find_n_Highlight() S2.Activate 'активируем нужный лист
Set whereImLooking = Worksheets("S2").Range("X2:X" & Worksheets("S2").Cells(Rows.Count, "X").End(xlUp).Row) ' переход на рабочий лист
On Error Resume Next: Err.Clear Dim ra As Range, cell As Range, res, txt$, v, pos& res = InputBox("Введите текст который нужно подсветить", "поиск", " ") If VarType(res) = vbBoolean Then Exit Sub ' нажата кнопка отмены txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub ' текст не введен или состоит из пробелов
Set ra = Range([X2], Range("X" & 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 End If Next cell
End Sub
Здравствуйте. Есть вот такое задание: 1. Есть код, организовать поиск введённого кода по таблице 2. Сначала: на полное совпадение затем на совпадение первых 4-х символов на совпадение последних 4-х символов далее поиск с заменой схожих символом : B - 8, D - 0, g - 9, G - 6 , I - 1, i -1, l - 1, O - 0, s - 5, S - 5, поиск производиться с постепенной подменой символов(лестницей) + коминация этих символов
сам код находиться в столбце Х (Serial_Number) сам фаил с таблицами Ссылка удалена администрацией
С поиском и выделением вроде справиося
Sub Find_n_Highlight() S2.Activate 'активируем нужный лист
Set whereImLooking = Worksheets("S2").Range("X2:X" & Worksheets("S2").Cells(Rows.Count, "X").End(xlUp).Row) ' переход на рабочий лист
On Error Resume Next: Err.Clear Dim ra As Range, cell As Range, res, txt$, v, pos& res = InputBox("Введите текст который нужно подсветить", "поиск", " ") If VarType(res) = vbBoolean Then Exit Sub ' нажата кнопка отмены txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub ' текст не введен или состоит из пробелов
Set ra = Range([X2], Range("X" & 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 End If Next cell