Option Explicit
Sub test()
Dim rng As Range, r As Range
With Sheets("Feuil1").Range("a1").CurrentRegion.Offset(1)
'S'il y a en-têtes
Set rng = .Columns("a").Resize(.Rows.Count - 1)
rng.Cells(1, 4).CurrentRegion.ClearContents
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For Each r In rng.Cells
If r(, 2).Value = "" Then
.Item(r.Value) = .Item(r.Value) + 1
End If
Next
'restitution è côté du tableau initial
If .Count > 0 Then
rng.Cells(1, 4).Resize(.Count, 2).Value = _
Application.Transpose(Array(.keys, .items))
Else
MsgBox "Aucune donnée"
End If
End With
End With
Set rng = Nothing
End Sub