从Word到Excel中find文本后复制文本

所以我一直在使用代码如何使用Excelmacros将一段文本从Word复制到Excel？ 将某些find的文本复制到Word中。 不过，我现在需要在find的string后复制一定数量的字符。 这是迄今为止的代码：

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:[e-mail]">[e-mail]</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:[e-mail]">[e-mail]</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:[e-mail]">[e-mail]</a><br> 

我只需要[e-mail] ，每次findstring，就可以粘贴到Excel中。

Answer 1

如果您的string始终与[e-mail]格式[e-mail] ，请将文档的全部内容分配给stringvariables，然后使用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

这可能不是一个精致的解决scheme，但是它运行良好，使用最基本的function（而不是某人可能会build议的RegEx）。

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

 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:[e-mail]"">[e-mail]</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（“Email：”，A50）= MID（A50，B50 + 6，LEN（A50）-B50 + 1）输出您的电子邮件

您的数据是A50，电子邮件地址是：[e-mail]。 列B50是相邻小区