Voilà une proposition utilisant une collection =) Ci-joint le fichier d'exemple.
Public Sub neelix()
Dim dico As Scripting.Dictionary
Set dico = New Scripting.Dictionary
Dim nbLignes As Long, numLigne As Long, chaine As String
nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
For numLigne = 1 To nbLignes
chaine = CStr(Cells(numLigne, "A"))
If dico.Exists(chaine) Then
dico.Item(chaine) = dico.Item(chaine) + 1
Else
dico.Add chaine, 1
End If
Next numLigne
Dim i As Long, key As Variant, j As Long, ouEcrire As Long
ouEcrire = 1
For Each key In dico.Keys
ouEcrire = ouEcrire + 1
For j = 1 To dico.Item(key)
'on écrit puis on incrémente
Cells(ouEcrire, "B").Value = key
ouEcrire = ouEcrire + 1
Next j
Next key
End Sub