Формула Excel для получения всех адресов электронной почты из одной ячейки

Question

Привет гуру, нужна ваша помощь с формулой Excel или кодом Excel vba, чтобы получить все адреса электронной почты из одной ячейки, заполненной текстами (до), и разделить их по строкам (после). Спасибо! Ниже приведен пример:

Agent1 agent.1@company.com Agent2 agent.2@company.com Agent3 agent.3@company.com Agent4 agent.4@company.com

Answer 1

можно использовать ФИЛЬТР XML:

Если есть формула Dynami c Array, просто поместите ее в первую ячейку, и Excel выдаст результаты вниз.

=FILTERXML("<a><b>"&SUBSTITUTE(A2," ","</b><b>")&"</b></a>","//b[contains (.,'@')]")

---

Если у кого-то нет формулы массива Dynami c, перенесите его в INDEX и скопируйте вниз:

=INDEX(FILTERXML("<a><b>"&SUBSTITUTE($A$2," ","</b><b>")&"</b></a>","//b[contains (.,'@')]"),ROW(ZZ1))

---

И если у него нет ФИЛЬТРА XML, мы можем использовать:

=INDEX(TRIM(MID(SUBSTITUTE($A$2," ",REPT(" ",999)),(ROW($ZZ$1:INDEX($ZZ:$ZZ,LEN($A$2)-LEN(SUBSTITUTE($A$2," ",""))+1))-1)*999+1,999)),AGGREGATE(15,7,ROW($ZZ$1:INDEX($ZZ:$ZZ,LEN($A$2)-LEN(SUBSTITUTE($A$2," ",""))+1))/(ISNUMBER(SEARCH("@",MID(SUBSTITUTE($A$2," ",REPT(" ",999)),(ROW($ZZ$1:INDEX($ZZ:$ZZ,LEN($A$2)-LEN(SUBSTITUTE($A$2," ",""))+1))-1)*999+1,999)))),ROW($ZZ1)))

Это формула массива, которую необходимо подтвердить. с помощью Ctrl-Shift-Enter вместо Enter при выходе из режима редактирования.

Answer 2

Извлечь электронное письмо из ячейки

Используйте 2-ю подписку для получения адресов электронной почты, а также 3-ю подписку для получения агентов.

Option Explicit

Sub getEmail(SourceCell As String, FirstTargetCell As String, _
  Optional Both As Boolean = False)

    Dim Source() As String, Email() As String, Agent() As String
    Dim i As Long, e As Long, a As Long

    Source = Split(Range(SourceCell))

    For i = 0 To UBound(Source)
        If InStr(1, Source(i), "@") > 0 Then
            GoSub writeEmail
        Else
            If Both Then GoSub writeAgent
        End If
    Next i

    If Both Then
        If a > 0 Then
            Range(FirstTargetCell).Resize(UBound(Agent) + 1) = _
              Application.Transpose(Agent)
        End If
    End If
    If e > 0 Then
        Range(FirstTargetCell).Offset(, Abs(Both)).Resize(UBound(Email) + 1) = _
            Application.Transpose(Email)
    End If

    If a + e > 0 Then
        MsgBox "Operation finished successfuly.", vbInformation
    Else
        MsgBox "Didn't find anything.", vbExclamation
    End If

GoTo exitProcedure:

writeEmail:
    ReDim Preserve Email(e)
    Email(e) = Source(i)
    e = e + 1
Return

writeAgent:
    ReDim Preserve Agent(a)
    Agent(a) = Source(i)
    a = a + 1
Return

exitProcedure:

End Sub

Sub getEmailOnly()
    Const SourceAddress As String = "A2"
    Const TargetAddress As String = "A6"
    getEmail SourceAddress, TargetAddress
End Sub

Sub getAgentAndEmail()
    Const SourceAddress As String = "A2"
    Const TargetAddress As String = "A6"
    getEmail SourceAddress, TargetAddress, True
End Sub

Answer 3

Или,

В A6, формула копируется до пустой:

=TRIM(MID(SUBSTITUTE(" "&$A$2," ",REPT(" ",399)),ROW(A1)*789,399))