VBA Content.Find in Word，如何在找到的文本右侧返回值

Question

我正在尝试从http://www.ozgrid.com/forum/showthread.php?t=174699修改代码

查找文件夹中的所有word文档，如果找到搜索值，则在列中返回“x”。 列名是文件夹中的文档。行名是搜索到的字符串。

我希望该例程返回一个值或字符串，该值或字符串位于右侧或 搜索字符串旁边的 word 文档中。

这将是一个很好的工具，可以从 Word 文档中的非结构化数据到 Excel 表格中收集日期、发票金额、姓名等。

With oDOC.Content.Find

                .ClearFormatting
                .Text = rCell.Value
                .MatchCase = False
                .MatchWholeWord = False

                .Execute

                If .Found Then

                    'Sheet1.Cells(rCell.Row, lngCol).Value = "x"    , returns an "x" if the word is found.


                End If

            End With

完整代码如下：

Public Sub SearchDocs()

    Dim oWRD As Object    '** Word.Application
    Dim oDOC As Object    '** Word.Document
    Dim oFound As Object  '** Word.Range

    Dim rCell As Excel.Range
    Dim lngCol As Long

    Dim strFile  As String

    On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    lngCol = 1

    '** Set oWRD = New Word.Application

    Set oWRD = CreateObject("Word.Application")
    oWRD.Visible = True

    '// XL2007 specific
    Sheet1.Range("B2:XFD100000").ClearContents

    strFile = Dir$(Sheet1.Range("B1").Value & "\*.doc?")
    lngCol = 2

    '// loop matching files
    Do While strFile <> vbNullString
        'open
        Set oDOC = oWRD.Documents.Open(Sheet1.Range("B1").Value & "\" & strFile)

        With Sheet1.Cells(2, lngCol)
            .Value = strFile
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 90
            .EntireColumn.ColumnWidth = 3.35
        End With

        For Each rCell In Sheet1.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)

            With oDOC.Content.Find

                .ClearFormatting
                .Text = rCell.Value
                .MatchCase = False
                .MatchWholeWord = False
                .Forward = False
                .Execute

                If .Found Then
                       'Selection.Collapse wdCollapseEnd
                       'Selection.Expand wdWord
                    'Sheet1.Cells(rCell.Row, lngCol).Value = "x"
                    'Sheet1.Cells(rCell.Row, lngCol).Value = .Text
                    Sheet1.Cells(rCell.Row, lngCol).Value = .Parent.Selection.Text

                End If

            End With
        Next
        Application.ScreenUpdating = True
        DoEvents
        Application.ScreenUpdating = False
        lngCol = lngCol + 1


        oDOC.Close
        '// get next file
        strFile = Dir$()

    Loop

    MsgBox "Finshed...", vbInformation

ErrHandler:
    Application.ScreenUpdating = True
    oWRD.Application.Quit

End Sub

我无法在网上找到或弄清楚如何返回找到的文本的范围，然后将其偏移以将文本/值返回到右侧。我知道该偏移量存在于 vba excel 中。但是如何偏移找到的字符串的范围，并将在这个偏移范围内找到的值返回给excel呢？

Answer 1

这种方法可能有效。首先将Range 对象初始化为您要搜索的范围

Set oFound = oDOC.Content

然后代替With oDOC.Content.Find 做

With oFound.Find

.Found = True 时，oFound 将移动到找到的文本。然后，您可以将 oFound 移动 1 个字，如下所示：

With oFound
    .MoveEnd Unit:=wdWord, Count:=1
    .MoveStart Unit:=wdWord, Count:=1
End With

您可以根据自己的要求调整Unit 和Count。根据您的需要，相关的范围对象方法MoveEndUntil、MoveEndWhile、MoveStartUntil 和MoveStartWhile 可能会提供更好的功能。查看这些和其他Range.Move 方法here。

希望有帮助

Answer 2

功劳归于 xidgel。非常感谢。它就像一个魅力。

编辑后的代码，按照xidgel的指导，可能对别人有帮助，我贴一下吧：

Public Sub SearchDocs()

    Dim oWRD As Object    '** Word.Application
    Dim oDOC As Object    '** Word.Document
    Dim oFound As Object  '** Word.Range



    Dim rCell As Excel.Range
    Dim lngCol As Long

    Dim strFile  As String

    'On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    lngCol = 1

    '** Set oWRD = New Word.Application

    Set oWRD = CreateObject("Word.Application")
    oWRD.Visible = True



    '// XL2007 specific
    Sheet1.Range("B2:XFD100000").ClearContents

    strFile = Dir$(Sheet1.Range("B1").Value & "\*.doc?")
    lngCol = 2

    '// loop matching files
    Do While strFile <> vbNullString
        'open
        Set oDOC = oWRD.Documents.Open(Sheet1.Range("B1").Value & "\" & strFile)
        Set oFound = oDOC.Content


        With Sheet1.Cells(2, lngCol)
            .Value = strFile
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 90
            .EntireColumn.ColumnWidth = 3.35
        End With

        For Each rCell In Sheet1.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)

            With oFound.Find                   'With oDOC.Content.Find
                Debug.Print rCell.Value

                .ClearFormatting
                .Text = rCell.Text
                .MatchCase = False
                .MatchWholeWord = False
                .Forward = True
                .MatchWildcards = True
                .Wrap = wdFindContinue
                .Execute

                Debug.Print .Found

                If .Found Then

                    With oFound
                        .Collapse wdCollapseEnd
                        .Expand wdWord

                        .MoveStart Unit:=wdWord, Count:=1
                        .MoveEnd Unit:=wdWord, Count:=5

                    End With

                    Sheet1.Cells(rCell.Row, lngCol).Value = oFound.Text
                    Debug.Print oFound.Text

                End If

            End With
        Next
        Application.ScreenUpdating = True
        DoEvents
        Application.ScreenUpdating = False
        lngCol = lngCol + 1


        oDOC.Close
        '// get next file
        strFile = Dir$()

    Loop

    MsgBox "Finshed...", vbInformation

ErrHandler:
    Application.ScreenUpdating = True
    oWRD.Application.Quit

End Sub