Sub Mail()
Plg = Sheets("Feuil1").UsedRange.Value
Set Dico = CreateObject("Scripting.Dictionary")
For i = LBound(Plg, 1) To UBound(Plg, 1)
For j = LBound(Plg, 2) To UBound(Plg, 2)
If Not IsError(Plg(i, j)) Then
If Plg(i, j) Like "*@*" Then
Dico(Plg(i, j)) = Dico(Plg(i, j)) + 1
End If
End If
Next j
Next i
With Sheets("Feuil2")
.Columns("A:B").ClearContents
.Cells(1, 1).Resize(Dico.Count, 1) = Application.Transpose(Dico.Keys)
.Cells(1, 2).Resize(Dico.Count, 1) = Application.Transpose(Dico.Items)
.Activate
End With
End Sub