Excel VBA：循环以将字符串剪切并粘贴到新行中

Question

我的目标概述如下：
1.循环浏览工作表上的行（列B）
2.如果该单元格包含多个电子邮件地址，则提取该电子邮件地址并将其粘贴到新行中（列B）。我需要处理的数据在一个单元格中可能包含两个以上的电子邮件地址。列A单元格将全部包含相同的数据。本质上，B列中的每个单元格应只包含一个电子邮件地址。
3.删除所有具有重复地址的行。
4.删除所有“垃圾”数据（##接收，发送）

在example3电子邮件和example4电子邮件下面的示例图片中，应将其剪切/粘贴到自己的行中，而示例5仍将保留。 目前，我的代码将所有空白行放在顶部。我没有将字符串剪切/粘贴到新的空白行中的解决方案。我也没有删除重复行的解决方案。

Sub FormatMessageTrace()

Dim a As Range
Dim b As Range
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String

Set a = Selection

On Error Resume Next

For Each b In a.Rows

str = b.Value
openPos = InStr(str, "")
closePos = InStr(str, ";")
midBit = Mid(str, openPos, closePos - openPos + 1)
ActiveCell.EntireRow.Insert shift:=xlDown
b.Replace midBit, ""

Next

Worksheets("Sheet2").Columns("B").Replace _
What:="##Receive, Deliver", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True

End Sub

数据示例： where you wire up

Answer 1

我发现对您的问题的描述相当混乱，但是希望该功能可以对您有所帮助。它的输入是任何字符串，其输出是输入字符串中包含的电子邮件列表。

Function RegExEmails(contents As String) As String

    Dim m As Match
    Dim c As MatchCollection
    Dim r As New RegExp

    With r
        .Pattern = "[^\s<(:]+@[^\s<>;,)]+[/\b\w+\b/g]"
        .Global = True
    End With

    Set c = r.Execute(contents)

    For Each m In c
        RegExtract = RegExtract & m.Value & ", "
    Next

    RegExEmails = Left(RegExtract, Len(RegExtract) - 2)
End Function

要使RegEx正常工作，您需要添加屏幕快照中突出显示的最后两个参考：

Answer 2

我用过：

• VBA阵列以加快处理速度
• 正则表达式，用于从字符串中提取电子邮件地址。
  • 用于提取所有有效电子邮件地址的正则表达式极其复杂，因此此规则有一些限制。例如，提供的正则表达式将不匹配使用IP地址而不是域名的电子邮件地址
• 确保我们排除重复电子邮件的字典
• 我使用后期绑定来简化和移植。您可以将其转换为早期绑定，这将在编写代码时提供Intellisense的优势，而且效率可能会稍微提高。
• 代码带有注释，但随时可以提问。

---

Option Explicit
Sub extEmails()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim dEmails As Object, RE As Object, MC As Object, M As Object
    Dim V As Variant, I As Long

    'Regex to match emails
    Const sPat As String = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}\b"

'Set source and results worksheets and ranges
'Change as you will. I used `sheet2` and column C for the results
Set wsSrc = Worksheets("sheet2")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 3)

'read source data into array
'assumes data is in Column B
With wsSrc
    vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With

'Initialize regex engine
Set RE = CreateObject("vbscript.regexp")
With RE
    .Pattern = sPat
    .Global = True
    .ignorecase = True
End With

'Initialize dictionary
Set dEmails = CreateObject("Scripting.Dictionary")
    dEmails.comparemode = vbTextCompare

'Create collection of unique email addresses
For Each V In vSrc
    If RE.test(V) = True Then
        Set MC = RE.Execute(V)
        For Each M In MC
            If Not dEmails.exists(M.Value) Then _
                dEmails.Add M.Value, M.Value
        Next M
    End If
Next V

'create results array
ReDim vRes(1 To dEmails.Count, 1 To 1)

'populate results array
I = 0
For Each V In dEmails
    I = I + 1
    vRes(I, 1) = V
Next V

'write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With
End Sub