Sub tt()
      Dim a(), c, i&, x As Range

      Application.ScreenUpdating = False
      With Sheets("Лист2"): a = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value: End With

      With CreateObject("scripting.dictionary"): .comparemode = 1
          For Each c In a: .Item(c) = 0&: Next

          With Sheets("Лист1"): a = .Range(.Cells(1, 4), .Cells(Rows.Count, 4).End(xlUp)).Value: End With
          ReDim b(1 To UBound(a), 1 To 1)
          For i = 1 To UBound(a)
              If .exists(a(i, 1)) Then b(i, 1) = 1
          Next

      End With

      With Sheets("Лист1")
          .[e1].Resize(UBound(b), 1) = b

          Set x = .[E:E].Find(1, , , xlWhole)
          If Not x Is Nothing Then
              .[E:E].ColumnDifferences(x).EntireRow.Hidden = True
              .[e1].Resize(UBound(b), 1).ClearContents
              .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
              .Rows.Hidden = False
          End If
      End With

End Sub