excel 从单个单元格获取所有电子邮件地址

uidvcgyl  于 2023-04-22  发布在  其他
关注(0)|答案(3)|浏览(209)

我需要,与Excel公式或VBA代码,以获得所有电子邮件地址从一个单一的文本单元格(前),并使他们分开每行(后)。
示例:

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

iqih9akk

iqih9akk1#

可以使用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进行确认。

zbdgwd5y

zbdgwd5y2#

或者
A6中,向下复制公式直至为空:

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

woobm2wo

woobm2wo3#

提取手机邮件

使用第二个子获取电子邮件地址,使用第三个子获取代理。

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

相关问题