Sub tt()
   Dim a, i&, t$, Dic As Object, Dic2 As Object
    Dim el, k, kk, x&
    
    a = Range("B2", Cells(Rows.Count, "A").End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 2)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = Trim(a(i, 2))
            If Len(t) Then
            If Not .exists(t) Then .Add t, CreateObject("Scripting.Dictionary")
            .Item(t).Item(a(i, 1)) = i
            End If
        Next
    End With
    
    For Each el In Dic.keys
        Set Dic2 = Dic.Item(el)
        If Dic2.Count > 1 Then
        For Each k In Dic2.keys
        x = 1
            For Each kk In Dic2.keys
            If k <> kk Then
                If Abs(k - kk) < 1 Then x = x + 1: b(Dic2.Item(k), 1) = x
                End If
            Next
        Next
        End If

    Next
[f2].Resize(UBound(b), 1) = b
End Sub