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

试试这个

定义两个范围，而不是合并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

扩展VBA中的范围

1 个答案: