将找到文本后的文本从 Word 复制到 Excel

Question

所以我一直在使用 How can I copy one section of text from Word to Excel using an Excel macro? 中的代码将某些找到的文本复制到 Word 中。但是，我现在需要在找到的字符串之后复制一定数量的字符的文本。这是到目前为止的代码：

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

Word 文档中的文本始终如下所示：

'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:last.first@location.company.com">last.first@location.company.com</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:last.first@location.company.com">last.first@location.company.com</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:last.first@location.company.com">last.first@location.company.com</a><br>

每次找到该字符串时，我只需要 last.first@location.company.com 粘贴到 Excel。

Answer 1

就优雅或性能而言，这可能不是一个绝妙的解决方案，但它运行良好并且使用了最基本的功能（与某些人可能建议的 RegEx 相反）。

它使用 InStr 函数来查找开始和结束标记，并使用 Mid 函数来获取它们之间的字符串。

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:last.first@location.company.com"">last.first@location.company.com</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

Answer 2

如果您的字符串始终采用相同的格式last.first@location.company.com，请将文档的全部内容分配给一个字符串变量，然后使用 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

编辑：

已更新子程序以捕获文档中的所有电子邮件

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

Answer 3

列 1 列 2 列 3 =FIND("Email:",A50) =MID(A50,B50+6,LEN(A50)-B50+1 ) 输出您的电子邮件

hERE A50 是您在 Email:xyz@xyz.com 中的数据。 B50 列是相邻单元格

将找到文本后的文本从 Word 复制到 Excel

Copy Text After Found Text from Word to Excel

excel

vba

ms-word