excel宏搜索单词和句子

Question

我希望有人可以帮助我解决这个问题。

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

标题字幕

 1. Name Address: Phone number: 2. Name Address: Phone number: 3. Name Address: Phone number: 

在excel文件中，我在D列中有一个单词列表。我要做的是从D列中提取单词，在Word文档中搜索它，然后将句子从“ Address：”之后复制到“。”。 ，将其放在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