Excel VBA: цикл, чтобы вырезать и вставить строку в новые строки

Question

Моя цель изложена ниже:
1. Прокрутка строк на листе (столбец B)
2. Если ячейка содержит более одного адреса электронной почты, извлеките адрес электронной почты и вставьте его в новую строку.(колонка B).Данные, которые мне нужно обработать, могут содержать более 2 адресов электронной почты в ячейке.Все ячейки столбца А будут содержать одинаковые данные.По сути, каждая ячейка в столбце B должна содержать только один адрес электронной почты.
3. Удалить все строки с дублирующимися адресами.
4. Удалить все «ненужные» данные (## Receive, Deliver)

В приведенном ниже примере примера электронная почта 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

Пример данных:

Answer 1

Я использовал:

• Массивы VBA, чтобы ускорить обработку
• Регулярное выражение для извлечения адресов электронной почты из ваших строк.
  • Регулярное выражение для извлечения всех действительных адресов электронной почты является чрезвычайно сложным, поэтому у этого есть некоторые ограничения.Например, предоставленное регулярное выражение не будет соответствовать адресам электронной почты, использующим IP-адрес вместо имени домена
• Словарь, чтобы исключить дублирование электронных писем
• Iиспользуется поздняя привязка для простоты и портативности.Вы можете преобразовать это в раннее связывание, которое обеспечит преимущество 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

Answer 2

Я нахожу описание вашей проблемы довольно запутанным, но, надеюсь, эта функция поможет вам.Его ввод - любая строка, вывод - список электронных писем, содержащихся во входной строке.

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 вам необходимо добавить две последние ссылки, выделенные на скриншоте: