Sub FioNomer()
Dim i As Long
Dim iLastRow As Long
Dim FAdr As String
Dim n As Integer
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("E2:E" & iLastRow).ClearContents
     n = 1
     For i = 2 To iLastRow
        If Cells(i, "C") < 6 Or Cells(i, "D") < 6 Then
          If Not dic.Exists(CStr(Cells(i, "B"))) Then
            dic.Add CStr(Cells(i, "B")), 1
            Cells(i, "E") = n
             n = n + 1
          End If
        End If
    Next
End Sub