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

Question

我正在尝试创建一个宏，该宏将在单击按钮时将列中的有效电子邮件地址复制到剪贴板，而忽略任何无效的电子邮件地址。我对 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）的“收件人”行中。我还考虑了其​​他解决方案，例如将所有有效的电子邮件地址添加到数组中，但是将数组复制到剪贴板似乎更复杂。无论哪种方式，如果有更优雅的解决方案，我都赞成。任何指针表示赞赏！

Answer 1

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

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（找到 here）将字符串复制到剪贴板，因为 MSForms 无法正常工作。但就是这样！

注意：我想为一些 cmets 投票，但我无法这样做，因为我还没有足够的声望。不过谢谢大家的建议！