Как выдернуть из строки подстроку по регулярному выражению?

Public Function RgxReplace(aregexp As String, _
astring As Range, _
areplace As String) As String
Dim re As RegExp
Set re = New RegExp
re.Pattern = aregexp
RgxReplace = re.Replace(astring, areplace)
End Function

Sub asd()
Dim a$(), s$
's = vbCrLf
's = vbCr
s = vbLf
's = vbLf & vbLf
With ActiveCell
  a = Split(.Value, s)
  .Offset(, 1) = a(0)
  .Offset(, 2) = a(1)
End With
End Sub

Sub asd
dim rn as range,a$()
for each rn in selection
  With rn
    a = Split(.Value, vblf)
    .Offset(, 1) = a(0)
    .Offset(, 2) = a(1)
  End With
next
end sub

Function yyy$(t$)
 With CreateObject("VBScript.RegExp"): .Pattern = "(.+)\s+" & uuu(t)
    yyy = .Execute(t)(0).Submatches(0)
 End With
End Function

Function vvv$(t$)
 With CreateObject("VBScript.RegExp"): .Pattern = "\(\d+\)\s+\d+"
    vvv = .Execute(t)(0)
 End With
End Function

Function uuu$(t$)
 With CreateObject("VBScript.RegExp"): .Pattern = "[-\w]+@[\w\.]+"
    uuu = .Execute(t)(0)
 End With
End Function

Function tttt(Text As String)
    Dim M As Object
    With CreateObject("VBScript.Regexp")
        .MultiLine = True
        .Pattern = "(?:\b)([\w\-\.]+@[\w\-\.]+)(?:\b)"
        Set M = .Execute(Text)
        If M.Count > 0 Then tttt = M(0).submatches(0)
    End With
End Function

Sub tt()
    Dim arr(), Rng As Range, I As Long, M As Object
    Set Rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    arr = Rng
    ReDim Preserve arr(1 To UBound(arr), 1 To 2)
    With CreateObject("VBScript.Regexp")
        .MultiLine = True
        .Pattern = "(?:\b)([\w\-\.]+@[\w\-\.]+)(?:\b)"
        For I = 1 To UBound(arr)
            Set M = .Execute(arr(I, 1))
            If M.Count > 0 Then
                arr(I, 2) = M(0).submatches(0)
                arr(I, 1) = Trim(Replace(arr(I, 1), arr(I, 2), " "))
            End If
        Next
    End With
    Rng.Resize(Rng.Rows.Count, 2) = arr
End Sub