Как отфильтровать столбец с несколькими динамическими c датами

Question

У меня есть макрос, в котором я могу фильтровать x количество раз, когда я хочу, чтобы в любом столбце любой книги отображалось только значение activecell. Я установил его на личные макросы, поэтому он работает с Excel вместо любой указанной c рабочей книги, что означает, что он работает со всеми рабочими книгами.

Теперь я пытаюсь создать макрос для обратного. Я хотел бы фильтровать, чтобы показать все, кроме значения активной ячейки несколько раз с любым столбцом. То есть, если у меня есть числа в столбце от 1 до 10, а активная ячейка находится в ячейке с 5, она покажет строки, имеющие только 1-4 и 6-10, и отфильтрует строки с 5 в этом столбце. Если я повторю это в другом столбце, который имеет az, но E уже отфильтрован из-за первого фильтра, и теперь активная ячейка находится на N, теперь он будет отфильтровывать строки с N и 5, et c.

Я заставил его работать, но в первый раз он очень прост с одной строкой кода и работает для каждого типа данных в столбцах (текст, числа, пробелы и даты), но когда я пытаюсь фильтровать второй раз и идти вперед, то, как я смог сделать код, делал копирование и вставку видимых ячеек ниже используемого диапазона, тогда он удаляет дубликаты и стирает значение активной ячейки. из списка, а затем он выполняет автофильтр с массивом того, что осталось в списке.

Это единственный способ, которым я смог сделать это, основываясь на моих возможностях с Excel.

Так far работает с текстами, числами и пробелами, но если в столбце есть какие-либо даты, он будет отфильтровывать их каждый раз, даже если активная ячейка отсутствует на одном из них.

Кто-нибудь знает, как я могу получить то, что этот фильтр по-другому или как решить проблему с датами?

Sub FilterOut()
Dim WS As Worksheet, i As Integer, FilterArray As Variant, Data As Range, D As Long, DatesArray As String

Application.ScreenUpdating = False

Set WS = ActiveSheet
On Error Resume Next
    Set Data = ActiveCell.ListObject.Range      'Filter tables
On Error Resume Next
If Data Is Nothing Then
    Set Data = ActiveCell.CurrentRegion
End If

C = ActiveCell.Column
Del = ActiveCell.Value

If WS.FilterMode = False Then       'Filterout the first time
    If Del = Empty Then             'For Filterout blank cells
        Data.AutoFilter Field:=C, Criteria1:="<>"
    Else
        Data.AutoFilter Field:=C, Criteria1:="<>" & Del
    End If
Else
    WS.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, C).Select    'Select the first row of the Filtered table, below the Header
    LR = WS.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row     'Get the LR of the filtered Table
    LR2 = WS.UsedRange.Rows(WS.UsedRange.Rows.Count).Row                                'Get the LR of the Original Table
    Range(Selection, Cells(LR, C)).Select                                               'Select all Visible cells in the column
    Selection.SpecialCells(xlCellTypeVisible).Copy                                      'Copy Selection

    Cells(LR2 + 5, C).PasteSpecial xlPasteValuesAndNumberFormats                        'Paste 5 rows below the Last Used Cell
    Application.DisplayAlerts = False
    With Selection
        RowsDelete = .Cells.Count                                                       'Know how many rows to delete at the end
        Application.CutCopyMode = False
        .RemoveDuplicates Columns:=1, Header:=xlNo                                      'Remove duplicates from list
        .Replace What:=Del, Replacement:="", lookat:=xlWhole                            'Deletes the ActiveCell Value from list

        WS.Sort.SortFields.Clear                                                        'Sort the list to remove empty cells
        WS.Sort.SortFields.Add Key:=Cells(LR2 + 5, C), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With WS.Sort
            .SetRange Range("A1:A" & RowsDelete).Offset(LR2 + 4, C - 1)
            .Apply
        End With
        ArrayRows = WorksheetFunction.CountA(.Cells)
        Min = WorksheetFunction.Min(.Cells)
        Max = WorksheetFunction.Max(.Cells)

        If Del <> Empty Then                                                'Show also blank cells
            Cells(LR2 + 5 + ArrayRows, C).Value = "="
            FilterArray = Join(Application.Transpose(Range(Cells(LR2 + 5, C), Cells(LR2 + 5 + ArrayRows, C))), ",")
        Else
            FilterArray = Join(Application.Transpose(Range(Cells(LR2 + 5, C), Cells(LR2 + 4 + ArrayRows, C))), ",")
        End If
        FilterArray = Split(FilterArray, ",")

        If Min = 0 Or Min > 60000 Or Max < 1 Then: GoTo NODATE              'Check if there might be Dates on the list

        For i = 1 To ArrayRows                                              'Go thru the list
            If IsDate(Cells(LR2 + 4 + i, C).Value) Then                     'Create a different array for dates
                D = D + 1
                If D = 1 Then                                               'Add the ( the first time
                    DatesArray = DatesArray & "(2,""" & CDate(Cells(LR2 + 4 + i, C).Value) & """"
                Else
                    DatesArray = DatesArray & ",2,""" & CDate(Cells(LR2 + 4 + i, C).Value) & """"
                End If
            End If
        Next i
        If D > 1 Then                   'Add ) to the end if there where any dates on the list
            DatesArray = DatesArray & ")"
        End If
    NODATE:
    End With

    WS.Range(WS.Rows(LR2 + 5), WS.Rows(LR2 + 5 + RowsDelete)).Delete Shift:=xlUp    'Delete the added rows

    Application.DisplayAlerts = True

    Data.AutoFilter Field:=C, Criteria1:=FilterArray, Operator:=xlFilterValues, Criteria2:=Array(DatesArray) 'Filter only the list

    WS.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, C).Select            'Select the first cell
End If
Application.ScreenUpdating = True

End Sub