Тема Вытянуть из столбца А уникальные адреса электронной почты
Код |
---|
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
|
Уникальные адреса электронной почты в столбце D , в столбце E их количество
В строках 13 и 14 электронные адреса не обрамлены <> и поэтому не подсчитаны