How to filter a column with multiple dynamic dates

[Rmejia]

I have a macro where I can filter x amount of times I want any column of any workbook to show only the activecell value. I have it installed on personal macros so it works with excel instead of any specific workbook meaning it works with all workbooks.

Now I'm trying to create a macro for the opposite. I will like to filter to show everything but the active cell value multiple times with any column. Meaning if i have numbers in a column from 1 to 10 and the activecell is on the cell that has 5, it will show the rows that have 1-4 and 6-10 only and will filterout the rows with a 5 in that column. If I repeat this in another column that has a-z but E is already filtered out due to the first filter, and now the active cell is on N, it will now filter out the Rows with the N and the 5, etc.

I got it to work but what it does is, the first time is very straight forward with one line of code and its working for every type of data on the columns (text, numbers, blanks and dates), but when I try to filter the second time and going forward, the way I was able to do the code was doing a copy and paste of the visible cells to below the range that is used, then it removes duplicates and erases the active cell value from the list and then it does an autofilter with the array of what is left on the list.

That's the only way I was able to do it base on my capabilities with excel.

So far is working for Texts, numbers and blanks, but if there are any dates in the column, it will filter them out everytime even though the active cell is not on one of them.

Does anyone know how can I get what this filter out in another way or how to fix the issue with the dates?

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(Split(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
ActiveSheet.UsedRange
End Sub