|
Поиск через VBA на примере проверки лотерейных билетов "Мечталлион". В ячейке F1 вводим цифру, ищет на листе и выделяет цветом, если нашлась.
Используются функции проверки изменения данных в ячейке, определения конца таблицы, поиска. В конце поста ссылка на скачивание XLSM файла.

Функция проверки изменений в ячейке F1:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Intersect(Target, Range("F1")) Is Nothing Then
If Not IsEmpty(Range("F1")) Then
lLastRow = Cells(Rows.Count, "A").End(xlUp).Row 'определяем последнюю строку по наличию данных в столбце A
FindValue ("A1:D" + Trim(Str(lLastRow))) 'передаём диапазон для поиска в функцию FindValue
End If
' Application.Run "Find.xlsm!FunctionName" 'пример вызова функции из другого файла
End If
End Sub
Функция поиска и выделения цветом:
Sub FindValue(r) 'r принимает значение области поиска в виде "A1:D9", вычисляется и передаётся из функции Worksheet_Change с Лист1
Dim c As Range
Dim firstAddress As String
With Worksheets(1).Range(r)
Set c = .Find(Range("F1").Value, LookIn:=xlValues, LookAt:=xlWhole) '"F1" - ищем данные из этой ячейки. LookAt:=xlWhole искать значение целиком, если убрать будет искать по вхождению.
If Not c Is Nothing Then
firstAddress = c.Address
Do
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And firstAddress <> c.Address 'в примере от MS не было проверки firstAddress, что приводило к зацикливанию
End If
End With
End Sub
Файл XLSM скачиваем тут...
|