excel - 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)的“收件人”行中。我还考虑了其他解决方案,例如将所有有效的电子邮件地址添加到数组中,但是将数组复制到剪贴板似乎更复杂。无论哪种方式,如果有更优雅的解决方案,我都赞成。任何指针表示赞赏!
解决方案
好的,经过进一步研究并感谢这里的一些回复,我设法提出了一个工作程序。使用正则表达式,因为它是我想要做的最简单的解决方案。这只是为了让我公司中的一些人让他们的生活更轻松一些,所以应该没问题。正则表达式模式不是万无一失的,但对于我们的目的来说已经足够好了。我可能会继续修剪它。无论如何,这是工作代码:
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(在此处找到)将字符串复制到剪贴板,因为 MSForms 无法正常工作。但就是这样!
注意:我想对一些评论进行投票,但我无法这样做,因为我还没有足够的声誉。不过谢谢大家的建议!
推荐阅读
- vue.js - 在 Vuetify Vue 中添加自定义图标或徽标
- python - Fenics - as_tensor 错误:ufl.log.UFLException:组件和形状长度不匹配
- c# - 实时绘制 WPF 的 3D 模型
- python - 基于分组后每组中最后一个值的内容的列的总和和计数
- python-3.x - 画布滚动条出现但不起作用
- java - 视频压缩不适用于 ffmpeg4android_lib 库
- asp.net - 尝试分页时出现 System.InvalidOperationException
- ansible - Ansible 字典变量定义
- sql - 具有 20 个固定值的 Azure 队列
- angular - 角度拖放性能