Расширенный фильтр и немного магии

Sub Расширенный_фильтр()
'Проверяем защищен ли проект VBA
If ActiveWorkbook.VBProject.Protection = 1 Then MsgBox "Проект защищен. Создание расширенного фильтра невозможно": Exit Sub

'Количество строк расширенного фильтра
kol = 6

'Проверяем установлин ли уже расширенный фильтр. Если да, то удаляем.
If Rows(2).Interior.Color <> 49407 Then

    If Selection.Rows.Count > 1 Then MsgBox "Нужно выделить не более одной строки", vbCritical: Exit Sub
    'Определяем границы выделенной области
    row1 = Selection.Row
    col1 = Selection.Column
    col2 = col1 + Selection.Cells.Count - 1
    'Вставляем строчки для расширенного фильтра
    For i = 1 To kol
        Range("A1").EntireRow.Insert
        If i > 1 Then Rows(1).Interior.Color = 49407
    Next i
    'Копируем шапку
    Range(Cells(row1 + kol, col1), Cells(row1 + kol, col2)).Select
    Selection.Copy
    Cells(1, col1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    'Формируем текст макроса
    MacroText = "Private Sub Worksheet_Change(ByVal Target As Range)" & Chr(13)
    MacroText = MacroText & "If Not Intersect(Target, Range(cells(2," & col1 & "),cells(" & kol - 1 & "," & col2 & "))) Is Nothing Then" & Chr(13)
    MacroText = MacroText & "On Error Resume Next" & Chr(13)
    MacroText = MacroText & "ActiveSheet.ShowAllData" & Chr(13)
    MacroText = MacroText & "cells(" & row1 + kol & "," & col1 & ").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=cells(1," & col1 & ").CurrentRegion" & Chr(13)
    MacroText = MacroText & "End If" & Chr(13)
    MacroText = MacroText & "End Sub"

    'Добавляем макрос
    ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule.AddFromString (MacroText)
    
Else:
    
    'Удаляем строки расширенного фильтра
    Range("A1:A" & kol).EntireRow.Delete
    Application.CutCopyMode = False
    
    'Удаляем макрос
    With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
             If .Find("Worksheet_Change", 1, 1, .CountOfLines, 1) = True Then
                iStartLine = .ProcStartLine("Worksheet_Change", 0)
                iCountLines = .ProcCountLines("Worksheet_Change", 0)
                .DeleteLines iStartLine, iCountLines
             End If
    End With
    
End If

End Sub 

Range("I1:O2").Select
    Range("A1:G3000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
        ("I1:O2"), CopyToRange:=Range("I9:O3039"), Unique:=False
 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:I5")) Is Nothing Then
   On Error Resume Next
   ActiveSheet.Unprotect Password:="123"
        ActiveSheet.ShowAllData
        Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
   ActiveSheet.Protect Password:="123"
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)                            'срабатывает на любое изменение листа, передаёт переменную Target по значению
    If Not Intersect(Target, Range("A2:K6")) Is Nothing Then                     'если нашлось хотя бы одно значение в пересечении диапазонов Target и "A2:K6"
        On Error Resume Next                                                                   'в случае ошибки следующей строки пропустить её
        ActiveSheet.ShowAllData                                                               'снять все фильтры
        Range("A9").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion    'От указанной ячейки определяется диапазон данных и применяется расширенный фильтр
    End If                                                                                                                                                               'Action определяет что фильтруем "на месте"
End Sub                                                                                                                                                                'CriteriaRange передается диапазон критериев, по которым будет фильтроваться таблица
 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("R2C1:R4C19")) Is Nothing Then
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("R7C1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("R1C1").CurrentRegion
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Range("F3:W4")) Is Nothing Then
            Dim lo As ListObject
            Set lo = ActiveWorkbook.Worksheets("Ваш лист").ListObjects("Ваша таблица")
        
            On Error Resume Next
                With Application:
                    .ScreenUpdating = False
                    .Calculation = xlCalculationManual
                End With

                lo.AutoFilter.ShowAllData
                If Not Intersect(Target, Range("F4:W4")) Is Nothing Then
                    lo.Range.CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, _
                    CriteriaRange:=Range("F2:W4")
                Else
                    lo.Range.CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, _
                    CriteriaRange:=Range("F2:W3")
                End If
            
                Set lo = Nothing
                With Application:
                    .Calculation = xlCalculationAutomatic
                    .ScreenUpdating = True
                End With
    End If
            
End Sub