Страницы: 1
RSS
Макрос для диапазона условий "одинаковое название + заполненная ячейка"
 
Здравствуйте!

Задача такая: если в ячейку вводится название мероприятия, нужно выполнить поиск по всем листам и, если найдётся совпадение названия мероприятия, отфильтровать лист с совпадением без пустых ячеек.

В прикреплённом файле пример: я ввожу на первом листе "мероприятие 1". Что нужно сделать, чтобы макрос нашёл "мероприятие 1" на другом листе и оставил в этом столбце только заполненные ячейки (образно говоря, оставил только фио тех, кто участвовал в мероприятии)?

Заранее спасибо, если кто-то хотя бы наведёт на мысль... У меня получался максимум автофильтр по уже известному столбцу (если, например, я знаю, что название мероприятия стоит в определённом столбце на определённом листе).  
Изменено: piligrim_211 - 28.02.2020 22:07:41
 
Цитата
хотя бы наведёт на мысль.
Пишите макрос на изменение содержимого ячейки С1 на первом листе
далее поиск по всем листам в строке 1 нужного мероприятия
перенос содержимого столбца на первый лист
 
Цитата
piligrim_211 написал:
на другом листе и оставил в этом столбце только заполненные ячейки (
это что значит? каждый лист в котором есть мероприятие указанное установить фильтр? или все фио перенести по указанному мероприятию на первый лист?
Изменено: Mershik - 28.02.2020 22:24:54
Не бойтесь совершенства. Вам его не достичь.
 
Текст в ячейке Лист1!C1 будет меняться. Если там "мероприятие 1", макрос пробегается по всем листам и оставляет активным тот, на котором есть столбец "мероприятие 1". А затем фильтр на этот столбец "мероприятие 1" (я не знаю, каким по счету и на каком листе он будет) - оставить заполненные ячейки.
 
piligrim_211, а т.е. мероприятие может быть только на одном листе?
Не бойтесь совершенства. Вам его не достичь.
 
В первом листе (С1) и в каком-то ещё. Скорее всего, "какой-то ещё" лист будет один.  
 
Цитата
я не знаю, каким по счету и на каком листе он будет
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("C1")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Sht As Worksheet
Dim iLastRow As Long
   For Each Sht In Worksheets
     If Sht.Name <> "Лист1" Then
       With Sht
         Set FoundCell = .Rows(1).Find(Target, , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
           'FoundCell.Column - столбец в котором нашли мероприятие
            iLastRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row
            .Activate
            'ставите фильтр
            Application.EnableEvents = True
            Exit Sub
         End If
       End With
     End If
   Next
 End If
  Application.EnableEvents = True
End Sub
 
Когда я меняю текст в ячейке D1 листа "Список мероприятий", ничего не происходит. Значит, макрос не работает? Не в красных ли строках ошибка? Там я пыталась записать, что нужно отфильтровать данные в столбце с совпадающим названием по признаку "исключить пустые".
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("D1")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Sht As Worksheet
Dim iLastRow As Long
   For Each Sht In Worksheets
     If Sht.Name <> "Ñïèñîê ìåðîïðèÿòèé" Then
       With Sht
         Set FoundCell = .Rows(1).Find(Target, , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
           &#39;FoundCell.Column - ??????? ? ??????? ????? ???????????
            iLastRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row
            .Activate
            ActiveSheet.ShowAllData
                       Selection.AutoFilter ' проблема здесь
                       ActiveSheet.Range("$A$1:$Z$200").AutoFilter Field:=FoundCell.Column, Criteria1:="<>"
                       Application.EnableEvents = True
            Exit Sub
         End If
       End With
     End If
   Next
 End If
  Application.EnableEvents = True
End Sub
Изменено: piligrim_211 - 29.02.2020 10:32:11
 
piligrim_211,
Копируйте и вставляйте код при русской раскладке клавиатуры
Код
Selection.AutoFilter ' проблема здесь

А что вы выделили?
И лучше привести пример.
 
В моём файле, в котором 75 листов с разными мероприятиями, лист с критериями называется "Список мероприятий", ячейка - D1. Для фильтра я записывала макрос через Excel: щёлкала на лист, в котором нашлось мероприятие, щёлкала на столбец с названием этого мероприятия и выбирала "Фильтр - кроме пустых". Но сейчас всё равно ничего не получается.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("D1")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Sht As Worksheet
Dim iLastRow As Long
   For Each Sht In Worksheets
     If Sht.Name <> "Список мероприятий" Then
       With Sht
         Set FoundCell = .Rows(1).Find(Target, , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
           'FoundCell.Column - столбец в котором нашли мероприятие
            iLastRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row
            .Activate
            Sheets("Стендовая стр").Select
    Selection.AutoFilter
                 ActiveSheet.Range("$A$1:$Z$200").AutoFilter Field:=FoundCell.Column, Criteria1:="<>"
     Application.EnableEvents = True
            Exit Sub
         End If
       End With
     End If
   Next
 End If
  
Application.EnableEvents = True
End Sub
Изменено: piligrim_211 - 29.02.2020 16:19:34
 
Цитата
В моём файле, в котором 75 листов с разными мероприятиями
Все листы для примера приводить не надо, достаточно 2-3
В макросе активируется лист, в котором нашли мероприятие из D1.
А вы выделяете лист Sheets("Стендовая стр").Select
А надо выделять диапазон на активном листе, чтобы установить фильтр
 
Но я же не знаю, какой именно будет диапазон... Вот, например, в D1 написано "Гран-При Кипр...". Такое же мероприятие есть на листе "Стендовая стр". Мне нужно, чтобы, когда я ввожу в D1 "Списка мероприятий" "Гран-При Кипр", осуществлялся переход на лист "Стендовая стрельба" и ставился фильтр на "Гран-При Кипр" - только заполненные.
Код
.Activate  ' активирую список
ActiveSheet.Range("$A$1:$Z$200").AutoFilter Field:=FoundCell.Column, Criteria1:="<>"  ' если макрос нашел активный лист, выделяю на нем диапазон, в который точно входит мероприятие, и ставлю фильтр по FoundCell - непустая
Application.EnableEvents = True

Но ничего не работает...
Изменено: piligrim_211 - 29.02.2020 21:39:47
 
Цитата
Когда я меняю текст в ячейке D1 листа "Список мероприятий", ничего не происходит
Потому что макрос должен быть в модуле листа , а не в стандартном модуле.
И еще у вас при переходе на лист "Стендовая стрельба" возникает какой-то круг и Excel виснет
 
Записала макрос на лист "Список мероприятий". Наверно, проблема в той части, которая выделена жирным?
Изменено: piligrim_211 - 29.02.2020 16:19:53
 
Попробуйте перезалить пример. Я уже вам писал, что вы не выделяете никакого диапазона,
но пишите Selection.AutoFilter
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D1")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Sht As Worksheet
Dim iLastRow As Long
   For Each Sht In Worksheets
     If Sht.Name <> "Список мероприятий" Then
       With Sht
         Set FoundCell = .Rows(1).Find(Target, , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
            iLastRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row
            .Activate
            ActiveSheet.Range("A1:M78").Select
            Selection.AutoFilter
            ActiveSheet.Range("$A$1:$M$78").AutoFilter Field:=FoundCell.Column, Criteria1:="<>"
            Exit Sub
            End If
            End With
     End If
   Next
 End If
  Application.EnableEvents = True
End Sub
Изменено: piligrim_211 - 29.02.2020 16:21:02
 
Глюк так и остался при переходе на лист "Стендовая стрельба" возникает какой-то круг и Excel виснет
Так что помочь в этом случае не могу.
 
Попробовать все заново написать? У меня этого круга нет...  
 
Попробуйте сохранить в формате .xls
и удалите все ненужные модули
 
piligrim_211,
Вот в примере результат работы макроса
 
C первого раза всё сработало, а потом перестало... В общем, с переменным успехом. В любом случае ОГРОМНОЕ Вам спасибо, это был архиважный вопрос, который с высокой долей вероятности удалось решить!!!
Изменено: piligrim_211 - 01.03.2020 10:04:13
 
piligrim_211,
Цитата
C первого раза всё сработало, а потом перестало
Возможно, каким-то образом, отключились события листа. Попробуйте запустить
Код
Sub ee()
  Application.EnableEvents = True
End Sub
 
Здравствуйте ещё раз. В Excel 2019 макрос не запускается, баг возникает на строке Selection.Autofilter...
 
Цитата
баг возникает на строке Selection.Autofilter...
Возможно, как и раньше я вам писал, что ничего не выделено.
В примере из сообщения #20, по моему, не выло никакого выделения,
а брался диапазон для автофильтра
Страницы: 1
Наверх