Sub UniqMail()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
Dim iMail As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "<(.+)>"
      iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("D2:D" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A2:A" & iLastRow).Value
  For i = 1 To UBound(arr)
    If .test(arr(i, 1)) Then
      iMail = .Execute(arr(i, 1))(0).submatches(0)
      dic.Item(iMail) = dic.Item(iMail) + 1
    End If
  Next i
   Range("D2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.Items))
 End With
End Sub