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

好的，经过一些进一步的研究并感谢这里的一些回答，我设法提出了一个工作程序。使用正则表达式，因为它是我尝试做的最简单的解决方案。这只是为了让公司中的一些人过得轻松一些，所以应该没问题。 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（找到here）将字符串复制到剪贴板，因为MSForms无法正常工作。就是这样！

注意：：我想对一些评论进行投票，但是由于我的声誉不够，所以无法这样做。但是谢谢大家的建议！

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

1 个答案: