Excel：使用空格分隔提取的电子邮件

我使用的是一个Excelmacros来从较长的string中提取电子邮件（例如“电子邮件[e-mail]将被解压缩” – 只会返回“[e-mail]”），唯一的问题是如果有两封电子邮件这个string会将它们作为一个大string返回，如下所示：“joe @ email.combob @ email.com”。 我想它是这样返回它：'[e-mail] [e-mail]'。 我将提供我正在使用的function来做到这一点，并希望有人知道如何修改它在当前的状态，以便它通过空间分隔电子邮件。

Function ExtractEmailFun(extractStr As String) As String 'Update 20130829 Dim CharList As String On Error Resume Next CheckStr = "[A-Za-z0-9._-]" OutStr = "" Index = 1 Do While True Index1 = VBA.InStr(Index, extractStr, "@") getStr = "" If Index1 > 0 Then For p = Index1 - 1 To 1 Step -1 If Mid(extractStr, p, 1) Like CheckStr Then getStr = Mid(extractStr, p, 1) & getStr Else Exit For End If Next getStr = getStr & "@" For p = Index1 + 1 To Len(extractStr) If Mid(extractStr, p, 1) Like CheckStr Then getStr = getStr & Mid(extractStr, p, 1) Else Exit For End If Next Index = Index1 + 1 If OutStr = "" Then OutStr = getStr Else OutStr = OutStr & Chr(10) & getStr End If Else Exit Do End If Loop ExtractEmailFun = OutStr End Function 

提前致谢！

Answer 1

如果您希望从当前输出string中replace换行符，如下所示

[e-mail]
[e-mail]

有一个空间，所以它看起来像

[e-mail] [e-mail]

你可以简单地改变

 OutStr = OutStr & Chr(10) & getStr 

成为

 OutStr = OutStr & " " & getStr 

Answer 2

看起来像这样可以更有效地完成。 我同意@nbayly拆分空间字符，迭代“单词”的数组，如果“单词”包含@那么你可以安全地假设它是一个电子邮件地址。

 Function GetEmails(words$) Dim word Dim emails As Object Set emails = CreateObject("Scripting.Dictionary") For Each word In Split(words, " ") 'Strip characters that you don't like: word = Replace(word, "'", "") word = Replace(word, ",", "") word = Replace(word, ")", "") word = Replace(word, "(", "") 'etc... word = Trim(word) 'Get rid of trailing periods word = IIf(Right(word, 1) = ".", Left(word, Len(word) - 1), word) If InStr(1, word, "@") <> 0 Then 'This is probably an email address ' adds to the dictionary emails(word) = word Else 'This is not an email address, do nothing End If Next GetEmails = Join(emails.Keys(), " ") End Function