Expanding a range in VBA - vba

Question

I am in the process of putting together a Word macro (below) that parses a table of acronyms in one Word document and highlights every occurrence of these acronyms in another Word document. This appears to be functional.
However, I would like to also have the macro differentiate acronyms that are in parentheses from those that are not. For example,
The soldier is considered Away Without Leave (AWOL). AWOL personnel are subject to arrest.
It seems as though the range "oRange" that defines the found acronym could be evaluated, if it is first expanded in the Do-While loop using this code:
oRange.SetRange Start:=oRange.Start - 1, End:=oRange.End + 1
However, none of my attempts to code a solution seem to work (they put the macro into an infinite loop or result in error messages). I'm fairly new to VBA programming and am obviously missing something regarding how the loops are operating.
My question is: is there a way to duplicate the range "oRange" for subsequent manipulation or is there some other method that I should be using?
Thanks for any assistance you can provide!
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

Try This
Define two ranges instead of merging the oRange.
See this sample code (TRIED AND TESTED)
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
SNAPSHOT
Unable to upload image at the moment. imgur server is down at the moment.
You may see this link
http://wikisend.com/download/141816/untitled.png