Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Поиск данных в отфильтрованном диапазоне
 
#1
03.07.2023 10:17:47
Доброго всем времени суток!!!
На листе работает макрос поиска. Вот код (прошу прощения, файл нет возможности предоставить - корпоративный интернет :():
Код
Sub Поиск_Яч(Optional t) 'поиск по листу
Static rLastFound As Range
  If IsMissing(t) Then 'вызов по горячей клавише
    If Not rLastFound Is Nothing Then Set rLastFound = Cells.FindNext(rLastFound)
  Else
    Set rLastFound = Cells.Find(What:=t, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
              'MsgBox "Не найдено!", vbExclamation, "ВНИМАНИЕ!!!"
            'Exit Sub
  End If
  If Not rLastFound Is Nothing Then rLastFound.Offset(0, 1).Activate
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address(0, 0) = "E1" Then
           Поиск_Яч Target 'поиск в ячейке E1
        End If
End Sub


Он работает только с отключенным фильтром, т.е. приходится всегда сначала отключить фильтр, потом найти нужные данные, потом снова отфильтровать диапазон. Подскажите, как дописать/изменить код, чтобы работал и на фильтрованном диапазоне, что необходимо для работы!
Спасибо!
 
 
 
#2
03.07.2023 11:08:48
evg_glaz, тестируйте
Код
Option Explicit

Sub Поиск_Яч(Optional t)
    ' Поиск по листу
    Static rLastFound As Range
    If IsMissing(t) Then ' вызов по горячей клавише
        If Not rLastFound Is Nothing Then Set rLastFound = Cells.FindNext(rLastFound)
    Else
        Set rLastFound = ActiveSheet.Cells.Find(What:=t, After:=ActiveSheet.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    End If
    If Not rLastFound Is Nothing Then Application.Goto rLastFound.Offset(0, 1)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Событие изменения на листе
    Application.EnableEvents = False
    ActiveSheet.AutoFilterMode = False
    
    If Target.Address(0, 0) = "E1" Then
       Поиск_Яч Target.Value ' поиск в ячейке E1
    End If
    
    Application.EnableEvents = True
End Sub
 
 
 
#3
03.07.2023 11:36:39
evg_glaz, здравствуйте
Алгоритм для поиска данных ТОЛЬКО в отфильтрованном диапазоне видимых ячеек.
Для поиска данных на листе вне зависимости, стоит фильтр или нет (всегда по всем данным) — просто забираете в массив весь UsedRange листа и ищите по нему (то есть, только последние шаги 6 и 7 алгоритма).

Если что-то непонятно, то создавайте отдельные темы с конкретными вопросами, а лучше — ищите по существующим.
Изменено: Jack Famous - 03.07.2023 11:38:29
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#4
03.07.2023 11:43:59
Prosvetov, спасибо! Ваш код снимает фильтр, а хотелось бы не снимая фильтр искать данные (именно в данном отфильтрованном диапазоне). Забыл сказать важное, прошу прощения - искомые данные в отфильтрованном диапазоне 100% есть (т.е. искомое не в скрытых строках)!
 
 
 
#5
03.07.2023 11:49:16
evg_glaz,
Код
Sub Поиск_Яч(Optional t)
    Static rLastFound As Range
    
    If IsMissing(t) Then ' вызов по горячей клавише
        If Not rLastFound Is Nothing Then
            Set rLastFound = Cells.FindNext(rLastFound)
        End If
    Else
        Dim rngVisible As Range
        On Error Resume Next
        Set rngVisible = SpecialCellsVisible(Range("A1").CurrentRegion)
        On Error GoTo 0
        
        If Not rngVisible Is Nothing Then
            Set rLastFound = rngVisible.Find(What:=t, LookIn:=xlValues, LookAt:=xlPart, _
                SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        End If
    End If
    
    If Not rLastFound Is Nothing Then
        rLastFound.Offset(0, 1).Activate
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "E1" Then
        Поиск_Яч Target.Value ' поиск в ячейке E1
    End If
End Sub

Function SpecialCellsVisible(rng As Range) As Range
    Dim cell As Range
    Dim rngVisible As Range
    
    For Each cell In rng.SpecialCells(xlCellTypeVisible)
        If rngVisible Is Nothing Then
            Set rngVisible = cell
        Else
            Set rngVisible = Union(rngVisible, cell)
        End If
    Next cell
    
    Set SpecialCellsVisible = rngVisible
End Function
 
 
 
#6
03.07.2023 11:50:45
Jack Famous, Спасибо! Попробую конечно... но, честно говоря ничего не понятно)))
 
 
 
#7
03.07.2023 12:02:40
Prosvetov, спасибо большое!!! Буду разбираться!
 
 
 
#8
03.07.2023 12:11:55
Код VBA. Функция и пример вызова
Описание
Изменено: Jack Famous - 03.07.2023 12:22:24
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#9
03.07.2023 12:25:20
Jack Famous, Благодарю!!!
 
 
 
#10
03.07.2023 12:40:05
Не забудьте добавить в последний пример только видимые ячейки с фильтра для переноса в массив (инструкция из сообщ. 3).
Изменено: Marat Ta - 03.07.2023 12:45:59
 
 
 
#11
03.07.2023 12:45:18
Prosvetov, Спасибо! Всё работает! Много макросов на листе мешают (выделение строки, копирование...вообщем всякое "Worksheet_SelectionChange"), наверное придется уходить от этого)))
Хорошего дня!!!
 
 
 
#12
03.07.2023 12:57:22
evg_glaz, небольшое изменение, и все ищет
Код
Sub Поиск_Яч(Optional t) 'поиск по листу
Static rLastFound As Range
  If IsMissing(t) Then 'вызов по горячей клавише
    If Not rLastFound Is Nothing Then Set rLastFound = Cells.FindNext(rLastFound)
  Else
'    Set rLastFound = Cells.Find(What:=t, LookIn:=xlValues, LookAt:=
    Set rLastFound = AutoFilter.Range.Find(What:=t, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
              'MsgBox "Не найдено!", vbExclamation, "ВНИМАНИЕ!!!"
            'Exit Sub
  End If
  If Not rLastFound Is Nothing Then rLastFound.Offset(0, 1).Activate
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address(0, 0) = "E1" Then
           Поиск_Яч Target 'поиск в ячейке E1
        End If
End Sub
 
 
 
#13
03.07.2023 13:51:16
RAN, выделяет синим "AutoFilter" в строке 7 и встает(
Изменено: evg_glaz - 03.07.2023 15:00:25
 
 
 
#14
03.07.2023 20:18:51
Цитата
evg_glaz написал:
выделяет синим "AutoFilter"
Заинтриговало. Проверил. Сие приключается, если Sub Поиск_Яч(Optional t) за каким-то рожном вставить не в модуль листа, а в стандартный модуль. В этом случае, конечно, так работать не будет. Исходя из #1 я сделал вывод, что у вас оба макроса в модуле листа. Нужно так (будет работать и в модуле листа, и в стандартном модуле).
 
Код
  Set rLastFound = ActiveSheet.AutoFilter.Range.Find(What:=t, LookIn:=xlValues, LookAt:= _
 
 
 
#15
04.07.2023 10:43:28
RAN, Marat Ta, Jack Famous, Prosvetov, большое спасибо за оказанную помощь!!! Всё работает!
С мира по нитке)))
 
 
 
#16
04.07.2023 10:53:32
Цитата
evg_glaz: С мира по нитке
это уместно, когда каждый немного привнёс, а тут вам полностью готовые решения дали, неподходящие вам только из-за того, что вы не можете нормально сформулировать проблему  :)
Изменено: Jack Famous - 04.07.2023 10:54:25
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#17
04.07.2023 12:13:14
Jack Famous, Вы совершенно правы! Здесь уместнее сказать не
Цитата
не можете нормально сформулировать проблему
а проблема, что файл-пример нет возможности приложить)
Спасибо Вам в любом случае!
 
 
 
Страницы: 1
Наверх