Vba word найти таблицу с текстом

    Dim MyRange, oRange As Range
    Dim MyRangeEnd As Long
    Dim strAcronym As String

    Set MyRange = ActiveDocument.Range
    MyRangeEnd = MyRange.End
    strListSep = Application.International(wdListSeparator)

    Set oRange = MyRange

        With oRange.Find
            .Text = "<[A-ZА-ЯЁ]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange
                
                ' VERY IMPORTANT line as for some docs Search gets stuck in headers/footers etc.
                If strAcronym = "" Then oRange.Start = oRange.Start + 1
                
                Debug.Print oRange.Start, "Table=" & Selection.Information(wdWithInTable), strAcronym

                '***********************************************************************
                'Манипуляции с найденным
                oRange.Expand Unit:=wdSentence
                Debug.Print strAcronym, oRange 'печать сокр. и предложения где оно найдено

                '***********************************************************************
                
                If oRange.Information(wdWithInTable) = True Then
                    oRange.MoveEnd wdCharacter, -1
                Else
                    oRange.Start = oRange.End
                    oRange.End = MyRangeEnd
                End If

            Loop

    Dim strSentence As String

                With oRange.Duplicate
                    .Expand Unit:=wdSentence
                    strSentence = .Text
                End With
                Debug.Print strAcronym, strSentence
                
                oRange.Collapse Direction:=Word.wdCollapseEnd

Вождь пишет:

With oRange.Duplicate
      .Expand Unit:=wdSentence
      strSentence = .Text
End With

Вождь пишет:

oRange.Collapse Direction:=Word.wdCollapseEnd

    Dim MyRange, oRange As Range
    Dim MyRangeEnd As Long
    Dim strAcronym As String

    Set MyRange = ActiveDocument.Range
    MyRangeEnd = MyRange.End
    strListSep = Application.International(wdListSeparator)

    Set oRange = MyRange

        With oRange.Find
            .Text = "<[A-ZА-ЯЁ]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange
                
                ' VERY IMPORTANT line as for some docs Search gets stuck in headers/footers etc.
                If strAcronym = "" Then oRange.Start = oRange.Start + 1
                
                Debug.Print oRange.Start, "Table=" & Selection.Information(wdWithInTable), strAcronym

                '***********************************************************************
                'Манипуляции с найденным
                With oRange.Duplicate
                       .Expand Unit:=wdSentence
                       strSentence = Trim(Replace(.Text, vbCr, ""))
                End With
                Debug.Print strAcronym, strSentence 'печать сокр. и предложения где оно найдено

                '***********************************************************************
                
                If oRange.Information(wdWithInTable) = True Then
                    oRange.MoveEnd wdCharacter, -1
                Else
                    oRange.Start = oRange.End
                    oRange.End = MyRangeEnd
                End If

            Loop

        End With

Dim R As Range

    Set R = Selection.Range
    R.End = R.StoryLength
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = False
        .Text = "^?"
    End With
    R.Find.Execute
    R.Select

Dim RWork As Range
Dim RFind As Range

    Set RFind = RWork.Duplicate
    With RFind.Find
        '...
        .Wrap = wdFindStop
    End With
    RFind.Collapse wdCollapseStart
    Do While RFind.Find.Execute
        If RFind.End > RWork.End Then Exit Do
        '...
        RFind.Collapse wdCollapseEnd
    Loop

Вождь пишет:

Для ясности, поместите курсор в середине таблицы и запустите код:

Вождь пишет:

R.Find.Execute
R.Select

    For i = 1 To 250
        R.Find.Execute
        R.Select
        Selection.Font.Bold = True
    Next

Приведенный мной выше код будет работать некорректно, в случае отнесения oRange на кусок выделенный внутри таблицы. Необходима доп. адаптация для определения позиции курсора внутри ячейки таблицы и т.п.

VBA-addict пишет:

…запустил — заданный код выделяет первый символ первой ячейки текущей строки таблицы…

VBA-addict пишет:

…все таблицы в моем случае шерстятся целиком…

Dim R As Range

    Set R = Selection.Range
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = False
        .Text = "^?"
    End With
    Do While R.End < R.StoryLength - 1
        R.Collapse wdCollapseEnd
        R.End = R.StoryLength
        R.Find.Execute
        If R.Find.Found <> True Then Exit Sub
        R.HighlightColorIndex = wdRed
    Loop

Вождь пишет:

Попробуйте, поместив курсор перед таблицей

Вождь пишет:

    Do While RFind.Find.Execute
        If RFind.End > RWork.End Then Exit Do
        ‘…
        RFind.Collapse wdCollapseEnd
    Loop

Do While RFind.Find.Execute and RFind.End <= RWork.End
    ...
Loop

    Dim MyRange, oRange As Range
    Dim MyRangeEnd As Long
    Dim strAcronym As String

    Set MyRange = ActiveDocument.Range
    MyRangeEnd = MyRange.End
    strListSep = Application.International(wdListSeparator)

    Set oRange = MyRange

        With oRange.Find
            .Text = "<[A-ZА-ЯЁ]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute And oRange.End <= MyRangeEnd
                'Continue while found
                strAcronym = oRange
                
                ' VERY IMPORTANT line as for some docs Search gets stuck in headers/footers etc.
                If strAcronym = "" Then oRange.Start = oRange.Start + 1
                
                Debug.Print oRange.Start, "Table=" & Selection.Information(wdWithInTable), strAcronym

                '***********************************************************************
                'Манипуляции с найденным
                With oRange.Duplicate
                       .Expand Unit:=wdSentence
                       strSentence = Trim(Replace(.Text, vbCr, ""))
                End With
                Debug.Print strAcronym, strSentence 'печать сокр. и предложения где оно найдено

                '***********************************************************************
                
                If oRange.Information(wdWithInTable) = True Then
                    oRange.MoveEnd wdCharacter, -1
                Else
                    oRange.Start = oRange.End
                    oRange.End = MyRangeEnd
                End If

            Loop

        End With

Вождь пишет:

Искать надо не в заданной области, а просто вперед проверяя попадание результата в область поиска.

Do While RFind.Find.Execute and RFind.End <= RWork.End
    ...
Loop

    RFind.Collapse wdCollapseStart
...
    RFind.Collapse wdCollapseEnd

Set myRgOrig = myRange.Duplicate
    ...
Do While .Execute And oRange.InRange(myRgOrig)
    ...
Loop
...