Поиск адресов электронной почты (email) на листе Excel

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

В прикреплённом файле, на первом листе ("исходные данные"), ячейки заполнены неструктурированной информацией (смесь фамилий, адресов почты, прочей ненужной информации)

Макрос вычленяет из текста ячеек адреса электронной почты, и выводит все найденные адреса email в таблицу на втором листе ("результат")

Конечно, не помешало бы ещё проверить все найденные адреса почты на корректность (на соответствие стандартам RFC 5322 и RFC 5321), но в данном макросе это не реализовано (но обычно это и не требуется)

Для поиска адресов email используются регулярные выражения (RegExp)

Также рекомендуем обратить внимание на настройку для программы Парсер сайтов Сбор email на интернет-сайтах. Настройка позволяет проходить по списку сайтов и искать е-мейл на основной странице и странице контактов.

 

Есть в наличии также другая версия этого макроса, который выводит найденные адреса email в те же строки листа, где они были найдены:

Если вам нужна именно такая версия макроса, оплачивайте 450 руб, и напишите на почту order@excelvba.ru письмо с темой «Покупка макрос поиска email» с указанием, когда и куда оплатили.
После получения оплаты, я вышлю вам на почту файл с макросом.

Dim coll As Collection
 
Sub EmailsList()
    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)
    ' ищет в тексте txt адреса электронной почты,
    ' все найденные адреса добавляются в коллекцию coll
    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

Вложения:
FindEmails.xls33.5 КБ

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Огромное вам спасибо! ВЫ СУПЕР ЧЕЛОВЕК!!!!!!!!!!! =))))))))

Супер! Спасибо!

Спасибище!

Все мои макросы написаны под Windows, - потому и не работает.
Чтобы этот макрос заработал на Маке, - его надо переделывать.

Здравствуйте! К сожалению, даже не работает в вашем исходном файле: "Не удается найти макрос...". Но я работаю на Mac OS – имеет ли это значение? Спасибо!

Отличный скрипт, просто слов не нахожу, прекрасно работает, и сортирует так как мне нужно, Спасибо большое создателю скрипта

Спасибо огромное автору!!! Всё работает на 5+!

Автор красавчик! Спасибо огромнейшее!

Для поиска URL нужен шаблон посложнее, - но тоже можно сделать
Ну и, возможно, придется немного код подправить.
Пробуйте, - код открыт ведь

Грааль)))
Я такой скрипт долго искал.
А если заменить строку RegExp.Pattern = "[\w]{1,}@[\w]{1,}
на RegExp.Pattern = "[\w]{1,}www[\w]{1,}
Макрос будет выводить url вместо email?

Спасибо, все работает!

Спасибо за отзывы) Ничего никуда скидывать не надо, - макрос бесплатный, пользуйтесь на здоровье.

Спасибо большое за инструмент! Огромное! Мегареспект! Куда скинуть благодарность?

Супер! респект автору

Автор - я тебя ЛУБЛУ!!! :-))
А если взаправду спасибо за помощь!!

Респект Автору!!!!!!!!!!!! Молодец!!!!

Здравствуйте, Степан.
Скорее всего, вы скопировали кнопку запуска макроса в свой файл (возможно, вместе с листом),
и кнопке до сих пор назначен макрос из исходного файла.
Попробуйте заново назначить кнопке макрос, - и все заработает.

При нажатии кнопки "Запуск" выдаётся сообщение: Не удаётся найти макрос "FindEmails.xls"
ЭтаКнигыа.EmailsList
В чём причина?

Спасибо большое автору макроса - под мои задачи макрос оказался максимально подходящим! Все есть, не делает ничего лишнего, полностью справляется со своей задачей! Спасибо Вам большое!

Не мог не написать автору благодарность) Все работает! 6800 строк ручками не перебрать) А тут такой макросище, все решил!

ОГРОМНЕЙШЕЕ СПАСИБО!!!!!

Конечно, это задача выполнима.
Оформляйте заказ на сайте, прикрепляйте примеры файлов, подробно описывайте, что и как должно работать.

Добрый день! Хорошая работа.
Есть следующая работа: нужна программа, которая позволяла делать нечто подобное, но с некоторыми усовершенствованиями:
1. Искать в неорганизованном тексте ячейки некоторые слова (или словосочетания) из пополняемого словаря
2. Переносить найденные слова в соответствующие ячейки другого файла Excel
3. В зависимости от значения слова записывать его в соответствующую колонку
Если задача выполнима, готов обсудить подробно (в т.ч. сроки и стоимость)

Супер макрос! рабочий! респект автору!

По стоимости:
1 пункт - недорого, особенно, если не надо проверять очередной адрес на наличие в текстовом файле
Зависит также от того, встраивать код в конкретный файл, или в надстройку, и требуются ли какие настройки вывода в текстовый файл.

По 2 пункту - всё сложнее. Сайты очень сильно отличаются друг от друга, поэтому для каждого из сайтов нужно своё решение.
Перебирать все страницы сайта - не вариант (число страниц может достигать миллионов)
Кроме того, для этих целей существуют специализированные программы.

1) Сколько будет стоить доработка программы таким образом чтоб я мог получать найденные емайлы в строчку через запятую в обычном текстовом документе ?
2) Можете написать программу для поиска емайлов не в текстовом документе а на сайте ?
Если да то стоимость работ ?

Улучшить макрос, конечно же, можно, - и в виде надстройки реализовать, и т.д. и т.п.
Но времени свободного у меня сейчас мало - так что сделаю это, только если вы готовы оплатить работу.

Я же, но уже точнее запрос (просьба). Можно ли чуть улучшить данный макрос (сделать его более удобным в работе):
1. Сделать в виде модуля
2. Перебор по всем листам книги (или выбор листов)
3. При отсутствии емейл на листе выдает ошибку
Заранее спасибо, Очень интересный сайт

Отличный маккрос, спасибо...Но макрос работает только в этой книге и переносить объемы информации на лист ИСХОДНЫЕ ДАННЫЕ не удобно. Как сделать, что бы это было в виде надстройки и работало в любой книге не зависимо от названия листов ?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
        _   _____      _                       
___ / | |___ / / \ __ __ _ __
/ __| | | |_ \ / _ \ \ \ /\ / / | '_ \
\__ \ | | ___) | / ___ \ \ V V / | |_) |
|___/ |_| |____/ /_/ \_\ \_/\_/ | .__/
|_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.