Создаем новый документ MS Excel.
В первом столбце у нас будут входные данные, содержащие Email адреса.
Во второй столбец мы вставляем формулу, которая заменяет символ новой строки (переносы) на символ пробела. Этим действием мы приводим всё содержимое ячейки к однострочному виду, даже если изначально текст там располагался в несколько строк.
=ЕСЛИ(ЕПУСТО(A1);СЦЕПИТЬ(A1;"Пустая строка");ПОДСТАВИТЬ(A1;СИМВОЛ(10);" "))
Растягиваем эту формулу на весь столбец.
Идем на вкладку «Разработчик» и открываем редактор скриптов VB
Открывается окно редактора скриптов. Для Листа 1 вставляем скрипт.
Вот сам скрипт.
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, 2).End(xlUp).End(xlUp).Row r2 = 1 Do s = Cells(r1, 2) 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 мы получим чистые электронные адреса.
Скачать готовый файл