Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lr&, i&
    If Target.Address <> "$F$2" Then Exit Sub
    Application.ScreenUpdating = False
    Rows.Hidden = False
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lr = lr + Cells(lr, 1).MergeArea.Rows.Count - 1
    If Cells(2, 6).Value = "В С Е" Then Exit Sub
    Rows("4:" & lr).Hidden = True
    For i = 4 To lr
        If Cells(i, 7) = Cells(2, 6) Then
            Range("A" & i).MergeArea.EntireRow.Hidden = False
        End If
    Next
End Sub

Private Sub Worksheet_Calculate()
    Dim r As Range, ar As Range, sRows As Range
    Dim dic As Object, adic, i&
    With ActiveSheet
        If .AutoFilterMode Then
            If .AutoFilter.Filters(7).On Then
                Application.ScreenUpdating = False
                Application.EnableEvents = False

                Set dic = CreateObject("Scripting.Dictionary")
                Set r = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
                For Each ar In r.Areas
                    For Each sRows In ar.Rows
                        dic.Item(sRows.Row) = 1
                    Next
                Next
                .AutoFilter.Range.AutoFilter Field:=7, Criteria1:="@"
                adic = dic.keys
                For i = LBound(adic) To UBound(adic)
                    Range("A" & adic(i)).MergeArea.EntireRow.Hidden = False
                Next
                Application.EnableEvents = True
                Application.ScreenUpdating = True
            End If
        End If
    End With
End Sub