mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

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

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

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

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

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

Также рекомендуем обратить внимание на настройку для программы Парсер сайтов Сбор 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 КБ5211 день 8 часов назад

Комментарии

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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