excel宏搜索单词并复制句子

Question

希望有人能帮我解决这个问题。

我有两个文档，一个是 Word，一个是 Excel。在 word 文件中，我有一个项目列表，例如：

标题副标题

1. Name

   Address:

   Phone number:

2. Name

   Address:

   Phone number:

3. Name

   Address:

   Phone number:

在excel文件中，我在D列中有一个单词列表。我想做的是从D列中取出单词，在Word文档中搜索它，然后将“地址：”后面的句子复制到“.”，将其放在C列（即左侧一个单元格），然后将“电话号码：”后面的句子复制到“。”并将其放在 B 列中。

我无法真正理解的部分是从第一组姓名、地址和电话号码到下一组。

有人可以帮助我了解如何执行此操作的宏吗？

我曾想过从这里扩展它：

Sub wordSearch()

' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
    Dim rng1 As Range
    Dim rng2 As Range
    Dim strTheText As String

    Set rng1 = ActiveDocument.Range
    If rng1.Find.Execute(FindText:="Example:") Then
        Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
        If rng2.Find.Execute(FindText:=".") Then
            strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
            MsgBox strTheText
        End If
    End If

End Sub

Answer 1

例如，下面的 Excel 子程序从与 Excel 文件位于同一文件夹中的 catalog.doc 获取整个文本，使用 RegExp 解析文本，循环访问联系人并将其放入 Dictionary，然后循环遍历D2:D10 单元格并将匹配名称的适当数据分别分配给 C 和 B 列。在 MS Office 2003、Windows 7 HB 中测试。

Option Explicit

Sub GetFromWord()

    ' Tools - References - add these:
    ' Microsoft Word 11.0 Object Library
    ' Microsoft VBScript Regular Expressions 5.5
    ' Microsoft Scripting Runtime

    Dim strCont As String
    Dim objCatalog As Scripting.Dictionary
    Dim objMatch As IMatch2
    Dim objElt As Range

    With New Word.Application
        .Documents.Open ThisWorkbook.Path & "\catalog.doc"
        With .ActiveDocument.Range
            .WholeStory
            strCont = .Text
        End With
        .Quit
    End With
    Set objCatalog = New Scripting.Dictionary
    With New RegExp
        .Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        For Each objMatch In .Execute(strCont)
            objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
        Next
    End With
    For Each objElt In Range("D2:D10")
        With objElt
            If objCatalog.Exists(.Cells(1, 1).Value) Then
                .Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
                .Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
            End If
        End With
    Next
End Sub

注意，Word 中重复的联系人会导致错误，不实施额外检查。

UPD：如果早期绑定有任何问题，您可以使用后期绑定CreateObject(ProgID)，如下所示，但这不是 VBA 中的最佳做法：

Option Explicit

Sub GetFromWordLBind()

    Dim strCont As String
    Dim objCatalog, objMatch, objElt As Object

    With CreateObject("Word.Application")
        .Documents.Open ThisWorkbook.Path & "\catalog.docx"
        With .ActiveDocument.Range
            .WholeStory
            strCont = .Text
        End With
        .Quit
    End With
    Set objCatalog = CreateObject("Scripting.Dictionary")
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        For Each objMatch In .Execute(strCont)
            objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
        Next
    End With
    For Each objElt In Range("D2:D10")
        With objElt
            If objCatalog.Exists(.Cells(1, 1).Value) Then
                .Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
                .Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
            End If
        End With
    Next
End Sub