在 VBA 中扩展范围

Question

我正在整理一个 Word 宏（如下），它解析一个 Word 文档中的首字母缩略词表，并​​突出显示另一个 Word 文档中这些首字母缩略词的每次出现。这似乎是功能性的。

但是，我还想让宏将括号中的首字母缩写词与括号中的首字母缩写词区分开来。例如，

该士兵被视为擅离职守 (AWOL)。擅离职守人员将被逮捕。

似乎可以评估定义找到的首字母缩写词的范围“oRange”，如果它首先在 Do-While 循环中使用以下代码进行扩展：

oRange.SetRange 开始：=oRange.Start - 1，结束：=oRange.End + 1

但是，我编写解决方案的任何尝试似乎都不起作用（它们将宏放入无限循环或导致错误消息）。我对 VBA 编程相当陌生，显然缺少有关循环如何运行的一些信息。

我的问题是：有没有办法复制“oRange”范围以进行后续操作，或者我应该使用其他方法吗？

感谢您提供的任何帮助！

---

Sub HighlightAcronyms()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim oRow As Row
Dim oCell As Cell
Dim sCellText As String

Dim oDoc_Source As Document
Dim strListSep As String
Dim oRange As Range
Dim n As Long
Dim sCellExpanded As String

    'Application.ScreenUpdating = False
    strListSep = Application.International(wdListSeparator)

'*** Select acronym file and check that it contains one table

wdFileName = WordApplicationGetOpenFileName("*.docx", True, True)
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
    TableNo = wdDoc.Tables.Count
    If TableNo = 0 Then
        MsgBox "The file """ & wdFileName & """ contains no tables.", _
        vbExclamation, "Import Word Table"

        ElseIf TableNo > 1 Then
             MsgBox "The file """ & wdFileName & """ contains multiple tables.", _
            vbExclamation, "Import Word Table"
    End If
End With

'*** steps through acronym column

wdDoc.Tables(1).Cell(1, 1).Select
Selection.SelectColumn
For Each oCell In Selection.Cells
    ' Remove table cell markers from the text.
    sCellText = Left$(oCell.Range, Len(oCell.Range) - 2)
    sCellExpanded = "(" & sCellText & ")"
    n = 1
    'need to find foolproof method to select document for highlighting
    Documents(2).Activate
    Set oDoc_Source = ActiveDocument

    With oDoc_Source
        Set oRange = .Range
        With oRange.Find
            .Text = sCellText
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = False
            Do While .Execute
                If n = 1 Then
                    oRange.HighlightColorIndex = wdGreen
                Else
                    oRange.HighlightColorIndex = wdYellow
                End If
       'trying to add code here to expand oRange and compare it to sCellExpanded
                n = n + 1
            Loop
        End With
    End With
Next oCell

Set wdDoc = Nothing
End Sub

Answer 1

试试这个

1. 定义两个范围而不是合并oRange。

查看此示例代码（试用和测试）

Sub Sample()
    Dim strSearch As String, sCellExpanded As String
    Dim oRange As Range, newRange As Range

    strSearch = "AWOL"
    sCellExpanded = "(" & strSearch & ")"

    Set oRange = ActiveDocument.Range

    With oRange.Find
        .ClearFormatting
        .Text = strSearch
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

         Do While .Execute
            If n = 1 Then
                oRange.HighlightColorIndex = wdGreen
            Else
                oRange.HighlightColorIndex = wdYellow
            End If

            '~~> To check if the found word is not the 1st word.
            If oRange.Start <> 0 Then
                Set newRange = ActiveDocument.Range(Start:=oRange.Start - 1, End:=oRange.End + 1)
                If newRange.Text = sCellExpanded Then
                    '
                    '~~> Your code here
                    '
                    newRange.Underline = wdUnderlineDouble
                End If
            End If
            n = n + 1
         Loop
    End With
End Sub

快照

暂时无法上传图片。 imgur 服务器目前已关闭。

你可能会看到这个链接

http://wikisend.com/download/141816/untitled.png