Excel公式从单个单元格中获取所有电子邮件地址答案

【问题标题】：Excel formula to get all email addresses from a single cellExcel公式从单个单元格中获取所有电子邮件地址
【发布时间】：2020-08-23 09:20:21
【问题描述】：

您好，大师们需要您的 excel 公式或 excel vba 代码的帮助，以从一个充满文本的单元格中获取所有电子邮件地址（之前），并将它们按行分隔（之后）。谢谢！下面是一个例子：

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

【问题讨论】：

代理的实际名称中有空格还是都是一个“单词”字符串？
您可以edit 将Before 字符串作为文本粘贴到帖子中吗？所以我们不需要重新输入。
你好，斯科特！是的，代理商的实际名称中有空格，已编辑。
对不起，我没有理解“在字符串作为文本之前”的意思。你能告诉我，以便我编辑吗？谢谢！
Edit 您的帖子包含要拆分为文本而不是照片的长文本字符串，以便我们可以复制粘贴。

标签： excel vba excel-formula excel-2013

【解决方案1】：

可以使用 FILTERXML：

如果有动态数组公式，那么只需将其放在第一个单元格中，Excel 就会将结果向下溢出。

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

如果没有动态数组公式，则在 INDEX 中换行并向下复制：

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

如果没有 FILTERXML 那么我们可以使用：

=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。

【讨论】：

哥们太棒了！但不幸的是，我无法让它在我的最终工作我不知道为什么......
您遇到了什么错误，您尝试了哪个公式？
前2个只是显示#value！这是最后一个显示#num！

【解决方案2】：

或者，

在A6 中，将公式复制到空白：

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

【讨论】：

【解决方案3】：

从单元格中提取电子邮件

使用 2nd Sub 获取电子邮件地址，也使用 3rd 获取代理。

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

【讨论】：