Sub SpisMes()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    r0_ = 3
    d0_ = Cells(r0_ - 1, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(r0_, 4).Resize(rd_, 2).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Перечень_накл").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        r_ = Cells(Rows.Count, 4).End(3).Row
        If r_ >= r0_ Then
            n_ = Cells(Rows.Count, 4).End(3).Row - r0_ + 1
            With .Sort 'для сортировки невошедших в список
                .SortFields.Clear
                .SortFields.Add Key:=Range("D" & r0_)
                .SetRange Range("D" & r0_).Resize(n_)
                .Apply
            End With
            ar1 = Cells(r0_, 4).Resize(n_, 2)
            ar0 = Range("B3:B15").Value
            With CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(ar0)
                    .Item(ar0(i, 1)) = i
                Next i
                For j = 1 To n_
                    ar1(j, 2) = .Item(ar1(j, 1))
                Next j
                Cells(r0_, 4).Resize(n_, 2) = ar1
            End With
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("E" & r0_)
                .SetRange Range("D" & r0_).Resize(n_, 2)
                .Apply
            End With
            Range("E" & r0_).Resize(n_).ClearContents
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub