Всем доброго здравия! Хотел создать такой вот интересный фильтр для удобства обработки данных. Дело в том, что в данном фильтре присутствует 2 макроса и по отдельности они оба работают, а вместе не дружат. Первый макрос закидывает данные по нужным ячейкам и листам, а второй должен фильтровать значения по введенным значениям. Первый макрос работает, а второй в паре с первым не хочет обрабатывать результат, но если на листах с фильтрацией вводить значения вручную, то работает, а это так не удобно, т.к листов более 10. Помогите исправить или допилить! Файл прилагается.
Всем доброго здравия! Хотел создать такой вот интересный фильтр для удобства обработки данных. Дело в том, что в данном фильтре присутствует 2 макроса и по отдельности они оба работают, а вместе не дружат. Первый макрос закидывает данные по нужным ячейкам и листам, а второй должен фильтровать значения по введенным значениям. Первый макрос работает, а второй в паре с первым не хочет обрабатывать результат, но если на листах с фильтрацией вводить значения вручную, то работает, а это так не удобно, т.к листов более 10. Помогите исправить или допилить! Файл прилагается.Кузьмич
Странно то, что у Вас одна из событийных процедур Private Sub Worksheet_Change находится в общем модуле, а не в модуле конкретного листа. Из общего модуля она не сработает.
Странно то, что у Вас одна из событийных процедур Private Sub Worksheet_Change находится в общем модуле, а не в модуле конкретного листа. Из общего модуля она не сработает.Gustav
Странно то, что у Вас одна из событийных процедур Private Sub Worksheet_Change находится в общем модуле, а не в модуле конкретного листа. Из общего модуля она не сработает.
можно ли это вообще исправить? Я применял сначала на листы, тоже самое было, а после в модуль закинул, подумал что так сработает, но увы.
Странно то, что у Вас одна из событийных процедур Private Sub Worksheet_Change находится в общем модуле, а не в модуле конкретного листа. Из общего модуля она не сработает.
можно ли это вообще исправить? Я применял сначала на листы, тоже самое было, а после в модуль закинул, подумал что так сработает, но увы.Кузьмич
Ну, теперь вся утка наша...
Сообщение отредактировал Кузьмич - Среда, 14.03.2018, 22:43
Если вы в первом макросе явно отключаете обработку событий, сиречь запуск любого событийного макроса, то почему вы считаете, что второй (событийный) макрос должен сработать?
Если вы в первом макросе явно отключаете обработку событий, сиречь запуск любого событийного макроса, то почему вы считаете, что второй (событийный) макрос должен сработать?RAN
Если вы в первом макросе явно отключаете обработку событий, сиречь запуск любого событийного макроса, то почему вы считаете, что второй (событийный) макрос должен сработать?
Если вы в первом макросе явно отключаете обработку событий, сиречь запуск любого событийного макроса, то почему вы считаете, что второй (событийный) макрос должен сработать?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sheet As Worksheet Dim rng As Range
If Intersect(Target, Range("A2:F3")) Is Nothing Then Exit Sub
On Error Resume Next ActiveSheet.ShowAllData
Range("A6:F" & Rows.Count).Clear
For Each sheet In Worksheets If Not sheet.Name = ActiveSheet.Name Then Set rng = sheet.Range("A5").CurrentRegion Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1) rng.Copy Range("A" & Rows.Count).End(xlUp).Offset(1) Application.CutCopyMode = False End If Next
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sheet As Worksheet Dim rng As Range
If Intersect(Target, Range("A2:F3")) Is Nothing Then Exit Sub
On Error Resume Next ActiveSheet.ShowAllData
Range("A6:F" & Rows.Count).Clear
For Each sheet In Worksheets If Not sheet.Name = ActiveSheet.Name Then Set rng = sheet.Range("A5").CurrentRegion Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1) rng.Copy Range("A" & Rows.Count).End(xlUp).Offset(1) Application.CutCopyMode = False End If Next
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then With Application MCalc = .Calculation .Calculation = xlCalculationManual .EnableEvents = False On Error Resume Next For Each cell In Intersect(Target, Range("A2:F3")) For Each Sheet In Worksheets If Not Sheet.Name = ActiveSheet.Name Then _ Sheet.Range(cell.Address) = cell Sheet.ShowAllData Sheet.Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheet.Range("A1").CurrentRegion Next Next .Calculation = MCalc .EnableEvents = True End With End If End Sub
[/vba]
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then With Application MCalc = .Calculation .Calculation = xlCalculationManual .EnableEvents = False On Error Resume Next For Each cell In Intersect(Target, Range("A2:F3")) For Each Sheet In Worksheets If Not Sheet.Name = ActiveSheet.Name Then _ Sheet.Range(cell.Address) = cell Sheet.ShowAllData Sheet.Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheet.Range("A1").CurrentRegion Next Next .Calculation = MCalc .EnableEvents = True End With End If End Sub
Решил обойти проблему методом копирования диапазона с Лист1 например на Лист2, но выдает ошибку 400.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then On Error Resume Next ActiveSheet.ShowAllData Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion End If End Sub Sub dabl() Range(Range("Лист1 A2:F3").Value).Copy Range(Range("Лист2 A2:F3").Value) End Sub
[/vba]
Хотел скопировать вводимые значения с Лист1 на Лист2
Решил обойти проблему методом копирования диапазона с Лист1 например на Лист2, но выдает ошибку 400.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then On Error Resume Next ActiveSheet.ShowAllData Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion End If End Sub Sub dabl() Range(Range("Лист1 A2:F3").Value).Copy Range(Range("Лист2 A2:F3").Value) End Sub
[/vba]
Хотел скопировать вводимые значения с Лист1 на Лист2Кузьмич
Ну, теперь вся утка наша...
Сообщение отредактировал Кузьмич - Четверг, 15.03.2018, 19:17
Тут дело в том что этот обход требует кнопку на выполнение, а мне автоматика нужна. [vba]
Код
Sub dabl() Range(Range("Лист1 A2:F3").Value).Copy Range(Range("Лист2 A2:F3").Value) End Sub
[/vba]
Каким образом подружить это чудо на одном листе с выше указанным копированием?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then On Error Resume Next ActiveSheet.ShowAllData Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion End If End Sub
Тут дело в том что этот обход требует кнопку на выполнение, а мне автоматика нужна. [vba]
Код
Sub dabl() Range(Range("Лист1 A2:F3").Value).Copy Range(Range("Лист2 A2:F3").Value) End Sub
[/vba]
Каким образом подружить это чудо на одном листе с выше указанным копированием?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:F3")) Is Nothing Then On Error Resume Next ActiveSheet.ShowAllData Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion End If End Sub
[p.s.]Ну и, может, я опять чего-то не понимаю, но у меня для Лист1 сложилось вот так (на базе процедуры от RAN):[/p.s.]
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'для листа Лист1
Dim sheet As Worksheet Dim rng As Range
Set rng = Me.Range("A2:F3")
If Intersect(Target, rng) Is Nothing Then Exit Sub
With Application MCalc = .Calculation .Calculation = xlCalculationManual For Each sheet In Worksheets If sheet.Name <> Me.Name Then rng.Copy sheet.Range(rng.Address) End If Next .Calculation = MCalc End With End Sub
[/vba] !!! При условии, что у всех остальных листов остаются активными собственные обработчики Worksheet_Change, которые обеспечивают фильтрацию на своих листах.
[p.s.]Ну и, может, я опять чего-то не понимаю, но у меня для Лист1 сложилось вот так (на базе процедуры от RAN):[/p.s.]
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'для листа Лист1
Dim sheet As Worksheet Dim rng As Range
Set rng = Me.Range("A2:F3")
If Intersect(Target, rng) Is Nothing Then Exit Sub
With Application MCalc = .Calculation .Calculation = xlCalculationManual For Each sheet In Worksheets If sheet.Name <> Me.Name Then rng.Copy sheet.Range(rng.Address) End If Next .Calculation = MCalc End With End Sub
[/vba] !!! При условии, что у всех остальных листов остаются активными собственные обработчики Worksheet_Change, которые обеспечивают фильтрацию на своих листах.Gustav
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
