Sub HelpExc()
Dim d As Object:    Set d = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet:    Set ws = Sheets("Sheet1")
Dim i As Long

For i = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
    If d.Exists(ws.Range("A" & i).Value) Then
        ws.Range("B" & i).Value = d.Item(ws.Range("A" & i).Value)
        d.Item(ws.Range("A" & i).Value) = CLng(d.Item(ws.Range("A" & i).Value) + 1)
    Else
        d.Item(ws.Range("A" & i).Value) = 1
    End If
Next i

End Sub