Вы уже знаете, как определить диапазон ячеек, в которых хранятся адреса электронной почты.Мое решение основано на этом для создания Dictionary уникальных адресов электронной почты, и в качестве дополнительного бонуса выполняет некоторую быструю проверку формата текстовой строки, которая, по вашему мнению, является адресом электронной почты.
Во-первых,чтобы проверить текстовую строку как проверку формата адреса электронной почты, я создал функцию, которая сначала ищет символ @, а затем проверяет, чтобы часть текста справа от разделителя имела хотя бы одну точку.
Private Function IsValidEmailFormat(ByVal thisText As String) As Boolean
IsValidEmailFormat = False
Dim tokens() As String
tokens = Split(thisText, "@")
If UBound(tokens) = 1 Then
'--- we found the domain separator, do we have a dot?
tokens = Split(tokens(1), ".")
If UBound(tokens) >= 1 Then
'--- we found the dot, looks like an email address
IsValidEmailFormat = True
End If
End If
End Function
Далее, мы будем использовать эту функцию для построения нашего Dictionary из заданного диапазона.Вы увидите, что внутри этой функции мы копируем данный диапазон в массив на основе памяти (подробнее об этом здесь ).После этого, убедившись, что у нас есть строка, которая является допустимым форматом электронной почты, проверьте, что она уже есть в словаре - вот как мы можем гарантировать, что у нас есть список УНИКАЛЬНЫХ адресов электронной почты.
Private Function GetUniqueEmails(ByRef thisRange As Range) As Dictionary
Dim theseEmails As Dictionary
Set theseEmails = New Dictionary
'--- copy to memory array
Dim thisData As Variant
thisData = thisRange
Dim i As Long
For i = LBound(thisData, 1) To UBound(thisData, 1)
If IsValidEmailFormat(thisData(i, 1)) Then
If Not theseEmails.Exists(thisData(i, 1)) Then
theseEmails.Add thisData(i, 1), i
End If
End If
Next i
Set GetUniqueEmails = theseEmails
End Function
Наконец, как вызывается из логики основного кода, вы можете делать то, что вы хотите с результирующим списком.Я сформировал список, разделенный точкой с запятой, похожий на ваш пример.
Вот весь пример кода в одном блоке:
Option Explicit
Sub TestMe()
Dim emails As Dictionary
Set emails = GetUniqueEmails(Sheet3.Range("A1:A5"))
'--- convert the emails to a semi-colon separated list for later use
Debug.Print "there are " & emails.Count & " emails in the list"
Dim emailList As String
Dim email As Variant
For Each email In emails.Keys
emailList = emailList & email & ";"
Next email
emailList = Left(emailList, Len(emailList) - 1) 'remove the trailing ";"
End Sub
Private Function GetUniqueEmails(ByRef thisRange As Range) As Dictionary
Dim theseEmails As Dictionary
Set theseEmails = New Dictionary
'--- copy to memory array
Dim thisData As Variant
thisData = thisRange
Dim i As Long
For i = LBound(thisData, 1) To UBound(thisData, 1)
If IsValidEmailFormat(thisData(i, 1)) Then
If Not theseEmails.Exists(thisData(i, 1)) Then
theseEmails.Add thisData(i, 1), i
End If
End If
Next i
Set GetUniqueEmails = theseEmails
End Function
Private Function IsValidEmailFormat(ByVal thisText As String) As Boolean
IsValidEmailFormat = False
Dim tokens() As String
tokens = Split(thisText, "@")
If UBound(tokens) = 1 Then
'--- we found the domain separator, do we have a dot?
tokens = Split(tokens(1), ".")
If UBound(tokens) >= 1 Then
'--- we found the dot, looks like an email address
IsValidEmailFormat = True
End If
End If
End Function