10:17
Excel поиск через VBA

Поиск через 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 скачиваем тут...

Категория: Excel, VBA | Просмотров: 30 | Добавил: Gonzales115 | Рейтинг: 0.0/0
Всего комментариев: 1
avatar
0
1 Gonzales115 • 10:45, 23.05.2025
полезный ресурс тут:
http://www.excelworld.ru/board....-1-0-11
avatar
close