Copy Text After Found Text from Word to Excel

1
votes

So I have been using code from How can I copy one section of text from Word to Excel using an Excel macro? to copy certain found text into Word. However, I now need to copy text for a certain number of characters AFTER the found string. Here is the code so far:

Sub FindAndCopyNext()

    Dim TextToFind As String, TheContent As String
    Dim rng As Word.Range

    TextToFind = "Delivery has failed" 'Not sure if this is best string option

    Set rng = wdApp.ActiveDocument.Content
    rng.Find.Execute FindText:=TextToFind, Forward:=True

    If rng.Find.Found Then
        'Need to return text (TheContent) that follow the found text
        LastRow = Range("A" & Rows.Count).End(xlUp).Row + 1
        Range("A" & LastRow).Value = TheContent
    Else
        MsgBox "Text '" & TextToFind & "' was not found!"
    End If

End Sub

The text in the Word document always looks like this:

'Jibberish Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p><a href="mailto:[email protected]">[email protected]</a><br>
'Jibberish Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p><a href="mailto:[email protected]">[email protected]</a><br>
'Jibberish Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p><a href="mailto:[email protected]">[email protected]</a><br>

I need just the [email protected], each time that string is found, to paste into Excel.

3
vbaexcelms-word

3 Answers

2
votes

If your string always the same format [email protected], assign the entire content of your document to a string variable, and then use RegEx

Sub FindAndCopyNext()
    Dim wordString As String
    wordString = wdApp.ActiveDocument.Content ' assign entire content of word document to string
    Dim rex As New RegExp
    rex.Pattern = ":(\w+\.\w+@\w+\.\w+\.com)" 'Rex pattern with a capturing group for email
    If rex.Test(wordString) Then
        Range("A1").Value = rex.Execute(wordString)(0).Submatches(0)
    End If
End Sub

Edit:

Updated Subroutine to capture all emails in document

Sub FindAndCopyNext()
    Dim wordString As String
    wordString = wdApp.ActiveDocument.Content ' assign entire content of word document to string
    Dim rex As New RegExp
    rex.Pattern = ":(\w+\.\w+@\w+\.\w+\.com)" 'Rex pattern with a capturing group for email
    rex.Global = True ' multisearch
    Dim i As Long: i = 1
    Dim mtch as Object
    If rex.Test(wordString) Then
        For Each mtch In rex.Execute(wordString)
            Range("A" & i).Value = mtch.Submatches(0)
            i = i + 1
        Next mtch
    End If
End Sub
1
votes

This may not be a brilliant solution in terms of ellegance or performance, but it works well and uses the most basic functions (as opposed to RegEx which someone may suggest).

It uses InStr function to find the starting and closing tags and a Mid function to get the string between them.

Sub Main()
    Dim str As String
    Dim a1 As Integer
    Dim a2 As Integer

    str = "<p><b><font color=""#000066"" size=""3"" face=""Arial"">Delivery has failed to these recipients or groups:</font></b></p>" & _
          "<font color=""#000000"" size=""2"" face=""Tahoma""><p><a href=""mailto:[email protected]"">[email protected]</a><br>"

    a1 = InStr(1, str, "<a href=""mailto:")
    a2 = InStr(a1, str, """>")

    Debug.Print Mid(str, a1 + Len("<a href=""mailto:"), a2 - a1 - Len("<a href=""mailto:"))
End Sub
-2
votes

cOLUM 1 COLUM 2 COLUMN 3 =FIND("Email:",A50) =MID(A50,B50+6,LEN(A50)-B50+1 ) OUTPUT YOUR EMAIL

hERE A50 is your data with Email:[email protected]. column B50 is adjacent cell