Как выделить из текста все адреса электронной почты?

[aldeano]

Всех с наступающим новым годом!!!
Возник следующие вопрос . имеется документ(прикрепляю Excel 2003) содержащие адреса хотелось бы убрать все лишние оставив только адреса (на выходе нужно получить список адрессов, в любом формате). Возможно ли это сделать в эксель без особых заморочек.

[IgorGO]

выполните этот

Sub ExtractMail()
  Const SepChar As String = " <>[]:;,()"
  Dim r1 As Long, r2 As Long, s As String
  If Sheets.Count = 1 Then Sheets.Add after:=Sheets(1): Sheets(1).Activate
  Sheets(2).Columns(1).ClearContents
  r1 = Cells(Rows.Count, 1).End(xlUp).End(xlUp).Row
  r2 = 1
  Do
    s = Cells(r1, 1)
    p = 1
    Do
      p = InStr(p, s, "@")
      If p > 0 Then
        i = p: Do: i = i - 1:  Loop Until i = 1 Or InStr(SepChar, Mid(s, i, 1)) > 0
        p1 = i + IIf(InStr(SepChar, Mid(s, i, 1)) > 0, 1, 0)
        i = p: Do: i = i + 1:  Loop Until i = Len(s) Or InStr(SepChar, Mid(s, i, 1)) > 0
        p2 = i + IIf(InStr(SepChar, Mid(s, i, 1)) > 0, 0, 1)
        Sheets(2).Cells(r2, 1) = Mid(s, p1, p2 - p1)
        r2 = r2 + 1
        p = p + 1
      End If
    Loop Until p = 0
    r1 = r1 + 1
  Loop Until Cells(r1, 1) = ""
End Sub

с листа с адресами.
смотрите лист2 колонка 1. если какие-то адреса выбраны не правильно (с мусором), обратите внимание какими символами ограничен адрес в начале и в конце, добавьте эти символы в Const SepChar As String = " <>[]:;,()" и выполните макрос еще разок.

[EducatedFool]

Вот что получилось:



Вот весь код: (не уверен, что все адреса выводятся корректно - но с виду всё хорошо)

Dim coll As Collection

Sub test()
    Dim cell As Range: Application.ScreenUpdating = False
    Set coll = New Collection
    For Each cell In shs.UsedRange.SpecialCells(xlCellTypeConstants).Cells
        ParseAddresses cell.Text
    Next cell
    For Each Item In coll
        shres.Range("a" & shres.Rows.Count).End(xlUp).Offset(1) = Item
    Next
End Sub

Sub cl(): shres.[a4:a65000].ClearContents: End Sub

Sub ParseAddresses(ByVal txt As String)
    repl1$ = "ZZZXXXZZZ": repl2$ = "ZZZYYYZZZ": On Error Resume Next
    txt = Replace(txt, ".", repl1$): txt = Replace(txt, "-", repl2$)
    Set RegExp = CreateObject("VBScript.RegExp"): RegExp.Global = True
    RegExp.Pattern = "[\w]{1,}@[\w]{1,}" & repl1$ & "[\w]{1,}"
    If RegExp.test(txt) Then
        Set objMatches = RegExp.Execute(txt)
        For i = 0 To objMatches.Count - 1
            addr = objMatches.Item(i).Value
            addr = Replace(addr, repl1$, "."): addr = Replace(addr, repl2$, "-")
            coll.Add addr, addr ' только уникальные адреса
        Next
    End If
End Sub

(добавлено позже - может, кому пригодится)

Посмотрите самый простой способ, как организовать отправку почты (рассылку писем)
(с использованием программы заполнения документов по шаблонам, с последующей отправке по почте)

В программе есть возможность формировать письма по шаблону (с подстановкой данных из таблицы Excel),
прикреплять сформированные документы и файлы из выбранной папки, и много других возможностей.

[aldeano]

Спасибо уважаемые профессионалы!!!
Все работает крайне корректно и правильно.
Решил разобраться как работает , в макросе IgorGO логика понятна (поиск символа @ и дальше определение длины адреса в обе стороны до символов <>[]:;,()) , реализация после чтения мануалов проясняется.

Однако в макросе уважаемого EducatedFool ничего не понимаю (Sub cl(): shres.[a4:a65000].ClearContents: End Sub единственное понятное мне место), просьба просто на пальцах объяснить используемую логику программы и методов программирования.

Еще раз спасибо.

[IgorGO]

результаты сошлись?

у Игоря все "заточено" на использование "VBScript.RegExp".
не помню точно, кажется Doober продемонстрировал эту штучку (или он видел ее у EducatedFool и обронил фразу, что так и не разобрал до конца на что она способна).
учитесь у мастеров, я у них много чего высмотрел.

а у меня действительно все просто, как дубовые двери, макрос выглядел бы приблизительно так же, если бы я его писал лет 20 назад)))

[EducatedFool]

просьба просто на пальцах объяснить используемую логику программы и методов программирования

Эх, мне бы кто это объяснил... сам с трудом понимаю, как это работает))
Мой совет - не пытайтесь понять, как это работает. Просто используйте, если макрос работает правильно.

Объяснять принцип работы такого макроса - намного дольше, нежели написать код.

Суть его проста: перебираем в цикле все заполненные ячейки, и каждую ячейку проверяем на соответствие шаблону СИМВОЛЫ@СИМВОЛЫ.СИМВОЛЫ
Чтобы избежать проблем с лишними точками и дефисами, перед проверкой на соответствие шаблону делаем 2 замены, после проверки - 2 обратные замены.

Найденные адреса изначально засовываем в коллекцию: coll.Add addr, addr
Это делается для того, чтобы не выводить повторяющиеся адреса (в коллекцию попадают только уникальные)
Ну и по окончании всего этого в цикле перебираем все элементы коллекции, и выводим их один за другим на лист результатов.

Про использование регулярных выражений (RegExp) можно почитать здесь:
http://www.script-coding.com/WSH/RegExp.html

[aldeano]

да оба макроса все работают как часы без сбоев и нареканий (результаты двух макросов разные только за счет повторяющихся адресов, наличие отсутствие повторяющихся элементов не критично ).

Спасибо за пояснения, попробую понять, с чем едят этот RegExp.

[Рэммант]

Доброго времени суток, уважаемый EducatedFool!
Я понимаю, что данная тема обсуждалась уже больше 2-х лет назад, но помогите, пожалуйста разобраться.
Ваш макрос работает великолепно. Даже не знал что такое вообще возможно в экселе. Единственное, он выдаёт одинаковые адреса, тоже.
Выше Вы писали:
"Найденные адреса изначально засовываем в коллекцию: coll.Add addr, addr
Это делается для того, чтобы не выводить повторяющиеся адреса (в коллекцию попадают только уникальные)
Ну и по окончании всего этого в цикле перебираем все элементы коллекции, и выводим их один за другим на лист результатов."
Можете объяснить как это сделать по пунктам? Я сохранял найденное в файл coll.add, потом опять запускал макрос, но дубли всё равно оставались.. Я что-то не так делал?

[IgorGO]

Рэммант,
пока не видно что Вы сделали вообще, трудно сказать что сделали не так.
сильно настораживает это:

Я сохранял найденное в файл coll.add

"coll.add" - такое имя безусловно не противоречит требованиям файловой системы к именам файлов, и файл можно так назвать... но
в исходном тексте макроса
был создан обьект - коллекция coll,
coll.add - это вызов метода add обьекта coll

[Рэммант]

Здравствуйте уважаемый, IgorGO!
Немного задержался с ответом.. Если не брать в расчёт коллекцию(просто не понимаю для чего она нужна), то макрос работает очень хорошо. А одинаковые адреса он выдаёт так как почему-то оставляет их с точкой после домена.
Пример результата: vasya@bk.ru
vasya@bk.ru.
inna@pisem.net
inna@pisem.net.
Что нужно исправить в макросе, чтобы он понимал, что это 2 одинаковых е-мэйл, только в обоих случаях один с точкой в конце, а другой нет? И, соотвественно, выводил результат только vasya@bk.ru и inna@pisem.net