Автофильтр ссылка на ячейку в диапазоне между датами

Dim a, i&
  With Sheets("Áàçà")
    a = [c1].CurrentRegion.Columns(1)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a): .Item(a(i, 1)) = "": Next
        ComboBox1.List = .keys
    End With
    End With

Range("$B$2:$E$35766").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Range("H2:H4"), Unique:=False
        Sheets("Ëèñò2").Range("A:N").ClearContents 'Clear
         ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Ëèñò2").Cells(1)

Private Sub UserForm_Initialize()
Dim a, i&
    a = [c1].CurrentRegion.Columns(2)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a): .Item(a(i, 1)) = "": Next
        ListBox1.List = .Keys
    End With
End Sub

Dim MySelection() As String
Dim NCrit As Long
Dim HideRange As Range
Dim HideRows As Range
Dim TheCell As Range
    
 
    '1 - Reading the multiple entries in the listbox
    
    ReDim MySelection(1 To Me.ListBox_MultiSelect.ListCount)
    NCrit = 0
    For i = 1 To Me.ListBox_MultiSelect.ListCount
        If Me.ListBox_MultiSelect.Selected(i - 1) = True Then
            MySelection(i) = Me.ListBox_MultiSelect.List(i - 1, 0)
            NCrit = NCrit + 1
        End If
    Next i
    Redim Preserve MySelection(1 to NCrit)
    
    '2 - Filtering the data to show only what was selected
    
    Sheets("MySheet").Select
    Cells.EntireRow.Hidden = False
    Sheets("MySheet").AutoFilterMode = False
    Rows(1).AutoFilter
    
    Set HideRange = Nothing
    For i = 1 To NCrit
        Sheets("MySheet").UsedRange.AutoFilter Field:=3, Criteria1:="<>" & MySelection(i)
        If HideRange Is Nothing Then
            Set HideRange = Sheets("MySheet").AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        Else
            Set HideRange = Intersect(HideRange, Sheets("MySheet").AutoFilter.Range.SpecialCells(xlCellTypeVisible))
        End If
    Next i
    
    Sheets("MySheet").AutoFilterMode = False
    
    '3 - Hiding the rows that were not selected
    
    Set HideRows = Nothing
    For Each TheCell In HideRange
        If Rows(TheCell.Row).Hidden = False Then
            If HideRows Is Nothing Then
                Set HideRows = Rows(TheCell.Row)
            Else
                Set HideRows = Union(HideRows, Rows(TheCell.Row))
            End If
        End If
    Next TheCell
 
    HideRows.EntireRow.Hidden = True

    Dim dict As Object, i As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    'This autofilters based on selections made in LB1
    With ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                dict(.List(i)) = Empty
            Else
                ActiveSheet.Range("$B:$F").AutoFilter Field:=2
            End If
        Next i
    End With
   
    If dict.Count = 0 Then Exit Sub
    
    With Sheets("Áàçà")
        .Range("B1").AutoFilter
        .Range("$B:$F").AutoFilter Field:=2, Criteria1:=dict.keys, Operator:=xlFilterValues
    End With
    '------
    'This loads listbox2 based on the filters made in LB1
   ' Dim rngSource As Range, rCell As Range
   ' Set rngSource = Sheets("Áàçà").Range("N1:N4").SpecialCells(xlVisible) '<--Adjust the range
   ' With dict
     '   .RemoveAll
    
     '   For Each rCell In rngSource
         '   dict(rCell.Value) = Empty
      '  Next
        
      '  If .Count Then Me.ListBox1.List = Application.Transpose(.keys)
  '  End With