MS Excel — вытаскиваем электронные почты из текста

Microsoft Excel, Инструменты Комментировать

Создаем новый документ 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

Осталось только запустить данный скрипт