Excel VBA-验证列中的电子邮件地址并复制到剪贴板

我正在尝试创建一个宏，该宏将在单击按钮时将列中的有效电子邮件地址复制到剪贴板，忽略任何无效的电子邮件地址。我对VBA完全陌生，因此我遇到了一些困难。我已经浏览了整个互联网和堆栈交换，到目前为止，我得出了以下结论：

Private Sub CommandButton1_Click()

Dim clipboard As MSForms.DataObject
Dim Emails As String
Set r = Intersect(Range("B1").EntireColumn, ActiveSheet.UsedRange)

For Each i In r
    If Trim(i) Like "?*@[!.]*.[!.]*" Then
        If Not i Like "*@*@*" Then
            Emails = Emails & i
        End If
    End If
Next i

clipboard.SetText Emails
clipboard.PutInClipboard

End Sub

---

此代码用于计算列中的每个单元格，以确定电子邮件地址是否有效，如果有效，则将电子邮件地址附加到字符串电子邮件中。完成后，字符串将复制到剪贴板，以便粘贴到电子邮件客户端（即Outlook）的“收件人”行。我还考虑过其他解决方案，例如将所有有效的电子邮件地址添加到数组中，但将数组复制到剪贴板似乎更复杂。不管怎样，如果有一个更优雅的解决方案，我完全赞成。任何指点都很感激

好的，经过进一步的研究和这里的一些回复，我终于想出了一个可行的方案。使用regex是因为它是我正在尝试的最简单的解决方案。这只是为了让我公司的一些人的生活更轻松一点，所以应该没问题。正则表达式模式不是万无一失的，但对于我们的目的来说，它已经足够好了。我可能会继续修剪它。无论如何，以下是工作代码：

Private Sub CommandButton1_Click()

Dim Emails As String
Set r = Intersect(Range("B1").EntireColumn, ActiveSheet.UsedRange)

With CreateObject("VBScript.RegExp")
        .Pattern = "^[\w-\.]+@([\w-]+\.)+[A-Za-z]{2,3}$"
        For Each cell In r
            If .Test(cell.Value) Then
                Emails = Emails & cell.Value & "; "
                ClipBoard_SetData (Emails)
                cell.Interior.ColorIndex = 0
            Else
                cell.Interior.ColorIndex = 22
            End If
        Next cell
    End With

    MsgBox "Emails copied!"

End Sub

我还使用了一个API（find）将字符串复制到剪贴板，因为MSForms不工作。但就是这样

---

注意：我想对一些评论进行投票，但我无法这样做，因为我还没有足够的声誉。但谢谢大家的建议

这看起来像是用

like

进行的正则表达式验证，而

like

不起作用。您需要添加以使用该类型的逻辑。如果使用正则表达式，请包括一些预期的通过/失败案例。Yikes，验证电子邮件，OP。一旦您确定了“电子邮件地址查找字符串”，您就要小心了，是时候将其附加到您的

to:

行了，您需要将此

Emails=Emails&i

更改为此

Emails=Emails&“；”&i

——Outlook使用

字符作为默认的电子邮件地址分隔符，您需要将其放入。否则，您的字符串将看起来像
foo@bar.combaz@biff.com
当您需要
foo@bar.com; baz@biff.com
@Marcucciboy2-还有一个警告，禁止使用Regex验证电子邮件。制定解决方案对您有好处。非常值得向上感谢你！：）