Replace Sheets.Add with something like Sheets("Sheet2") if needed.
Sub test()
Dim a, b, i As Long, dic As Object, m As Object, temp As String
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
With Sheets("sheet1")
a = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
ReDim b(1 To UBound(a, 1), 1 To 3)
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.Pattern = "^.* && parent = ([^&]+) .*$"
For i = 1 To UBound(a, 1)
If .test(a(i, 1)) Then
For Each m In .Execute(a(i, 1))
temp = m.submatches(0)
If Not dic.exists(temp) Then
dic(temp) = dic.Count + 1
If UBound(b, 2) < dic.Count Then
ReDim Preserve b(1 To UBound(b, 1), 1 To dic.Count)
End If
b(1, dic(temp)) = temp
End If
b(i, dic(temp)) = b(i, dic(temp)) & _
IIf(b(i, dic(temp)) <> "", vbLf, "") & m
Next
End If
Next
End With
With Sheets.Add.Cells(1).Resize(UBound(b, 1), UBound(b, 2))
.Value = b
.VerticalAlignment = xlTop
.Columns.AutoFit
.Rows.AutoFit
End With
End Sub
Bookmarks