Microsoft Office Forums - View Single Post - Find a word in doc1, search for it in dictionary doc2, copy the meaning from doc 2 to doc 1

macropod · 09-15-2014, 08:54 PM

The subscript out of range messages is because your dictionary document has an empty paragraph. I did say it must not have such paragraphs...

The reason that (nice) wasn't updated is because the macro is using a case-sensitive Find (via .MatchCase = True). That's a safeguard against (Bill) and (bill) both being treated as boys' names. So, either you need to provide both upper and lower case definitions in your dictionary, or you can change:
.MatchCase = True
to:
.MatchCase = False
and risk some definitions being wrong.

Try the following code revision:

Code:

Sub AddDefinitions()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, j As Long, StrFnd As String, StrRep As String
 'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\Dictionary.doc")
FRList = FRDoc.Range.Text
FRDoc.Close False
Set FRDoc = Nothing
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWholeWord = True
    .MatchCase = True
    .Format = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .Replacement.Font.ColorIndex = wdBlue
    'Process each word from the Check List. Tab-delimited strings are assumed, formatted as:
    'Term <Tab> Definition
    For j = 0 To UBound(Split(FRList, vbCr)) - 1
      .Text = "(" & Split(Split(FRList, vbCr)(j), vbTab)(0) & ")"
      .Replacement.Text = "^&-" & Split(Split(FRList, vbCr)(j), vbTab)(1)
      .Execute Replace:=wdReplaceAll
    Next
    .MatchWildcards = True
    .Text = "\(*\)"
    .Replacement.Text = "^&"
    .Replacement.Font.ColorIndex = wdRed
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub