在VBA中擴展範圍

Question

我正在編寫一個Word宏（下面），它在一個Word文檔中解析縮略詞表，並​​在另一個Word文檔中突出顯示每個這些縮略詞的出現。這似乎是功能性的。

但是，我想也有宏觀區分在括號中的縮寫詞與不是。例如，

該士兵被認爲是離開（AWOL）。 AWOL人員受到逮捕。

它好像「橙色」定義發現縮寫的範圍內可以進行評估，如果在執行 - 而使用這個代碼迴路第一延展：

oRange.SetRange開始：= oRange.Start - 1，End：= 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