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

如果您的字符串始终采用相同的格式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 2

这在优雅或性能方面可能不是一个出色的解决方案，但它运作良好并且使用最基本的功能（而不是有人可能建议的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 3

cOLUM 1 COLUM 2 COLUMN 3 = FIND（“电子邮件：”，A50）= MID（A50，B50 + 6，LEN（A50）-B50 + 1）输出您的电子邮件

hERE A50是您的电子邮件数据：xyz@xyz.com。列B50是相邻的单元

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

3 个答案: