Данный макрос предназначен для поиска адресов электронной почты на листе 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
Комментарии
Макрос просто волшебный! Спасибо за ваш труд, все благ!
Привет из 2022! Спасибо за таблицу. Работает, если разрешить макросы!
Нет, работает только в Excel под windows
Работает на Google Таблицах?
спасибо!
Супер! Огромное спасибо!
ТЫ СПАС МОЙ МОЗГ - "СОЛНЦА" ТЕБЕ.
ЭТО НЕВЕРОЯТНО!
Огромное спасибо.
У меня вот тоже ошибка. Эксель для мака версия 16.23
Не удается выполнить макрос "FindEmails.xls!ЭтаКнига.EmailsList". Возможно, этот макрос отсутствует в текущей книге либо все макросы отключены.
Ваша программа просто гениальная, очень помогло кучу времени сохранил. Огромное вам спасибо!
Здравствуйте. Спасибо за полезный макрос. Подскажите пожалуйста, как сделать чтобы email адреса из таблицы с исходными данными удалялись при перемещении в результатный столбец?
Андрей, ну так включить макросы нужно
Обычно Excel выдаёт запрос на включение макросов при открытии файла, - возможно, вы не увидели, или нажали «не включать»
http://excelvba.ru/articles/EnableMacros/Excel
выдает вот что:
Не удается найти макрос "FindEmails.xls!ЭтаКнига.EmailsList".
Отлично все работает, спасибо большое. Очень помог, облегчил работу!)
Все работает! Огромное спасибо!
Спасибо Вам огромное!
Добрый день!
Сделайте пожалуйста такой же, но для сотовых и мобильных телефонов.
Спасибо!!! Отлично сработано! Оч помоги!!!!! Удачи Вам
Спасибо огромное за это файл. Вы меня просто спасли!!!!
Надо:
1) скачать файл из статьи
2) скопировать вашу таблицу целиком, вставить в мой файл на первый лист
3) в моём файле, перейти на второй лист, и нажать кнопку
Получите список email из ваших данных
Ребята, помогите чайнику!
Я вообще не понимаю, что и куда нажимать...
Имею экспортированный файл с почты gmail в csv формате с эмэйлами
В экселе открывается 2851 строчка и с каждая с кучей запятых,* и прочими знаками.
Научите, пожалуйста, куда тыкать.
Макросы включил (только это понял))
Огромное спасибо.
Работает замечательно
Большое спасибо!
Готового нет, но можем попробовать сделать под заказ
Большое спасибо!!
Скажите, пожалуйста, нет ли случайно похожего волшебства, которое ищет имена в файле. То есть так же как мэйлы, только имена ?
В прикрепленном файле макрос работает без ошибок
А если хотите в своем файле запустить - надо изменить в коде имена листов:
shs меняем на worksheets(1)
shres меняем (в 2 местах) на worksheets(2)
Подскажите, пожалуйста, выводится ошибка 424. Что это значит? Что я могу не так делать?
Спасибо!
Нет, это работает в любой версии Office (по крайней мере, начиная с Excel 2003 точно)
shs.UsedRange.SpecialCells( xlCellTypeConstants ).Cells это работает только с офиса 13(
Включите макросы в Excel, как показано здесь:
http://excelvba.ru/articles/EnableMacros/Excel
(надо выбрать опцию «разрешить все макросы»)
Здравствуйте, почему то когда нажимаю запуск то выходит сообщение что надо попросить автора подписать макросы с использованием серификата, выданного центром сертификации, скажите пожалуйста как быть?
Спасибо!
В интернете много инструкций, как скопировать код макроса (и где его найти), и как назначить макросу кнопку.
Если с этим сложности - используйте прикрепленный к статье файл, - там уже все работает, только кнопку нажать.
Извините за беспокойство, очевидно вопрос совсем глупый, но до этого дня не сталкивался с макросами, и узнал о существовании оных только сейчас.Не могу разобраться как применить ваш макрос к моему файлу. под кодом нашел ссылку на загрузку вашего файла эксель. Не могли бы вы описать подробно как применить макрос к моему файлу?
Заранее спасибо.
Паттерн не учитывает, но макрос учитывает. Запустите макрос в прикреплённом файле, и увидите, что в результате есть адреса почты с тире.
Так что все нормально с кодом. не учитывает он только особо сложные email, например с пробелами или несколькими @ (но такие на практике не встречаются, хотя в теории возможны)
PS: макрос я писал давно, - видимо, плохо тогда разбирался в регулярных выражениях, либо там какие-то еще нюансы были, почему я точки и тире через замены реализовал.
Ваш паттерн не учитывает тире
OMG! Волшебство прямо!!
СПАСИБО! БОЛЬШУЩЕЕ!!! )))
Спасибо. Даже нет.... спасибоще!
Драгоценные минуты жизни спасены от рутинной работы
Просто КРАСАВЧИК!!! Человечище
Спасибо, добрый человек! Это Гениально! Так держать!!!
Спасибо автору! выручили прям очень-очень.
Огромное спасибо, просто находка!!!!!!!!!!!!!!!!
Автору большое огромадное спасибо!! я тебя люблю, дорогой мой человек
СПАСИБО ОГРОМНЕЙШЕЕ! ЦЕНЫ ВАМ НЕТ!
Громаднейшее спасибо!!!! Макрос сэкономил несколько часов (а то и дней) моей жизни:)))
Да, повторы удаляются.
В коде это даже помечено:
Если надо без удаления повторов, - то замените эту строку на
Спасибо огромное!
Кучу времени сэкономило просто!
Если я правильно понял, то он также ищет повторяющиеся адреса эл почты и объединяет их в один, не так ли?
а хорошая все таки идетя, с базы примеров номера фильтровать. Создать лист где будут примеры контактов ххх-хх-хх хх-ххх-хх и так далее
С номерами телефонов сложнее намного, - они могут быть в разных форматах записаны (в отличие от email - где легко найти начало и конец email)
Можем сделать за денежку, - оформляйте заказ на сайте, прикрепляйте примеры файлов, и подробно описывайте, что и как должно работать.
А можно поправить чтобы он искал номера мобильных телефонов?
Отправить комментарий