Sub ProperNounToFRedit()
' Paul Beverley - Version 04.02.22
' Picks up alternative spellings in a PN query list for a FRedit list

Set thisDoc = ActiveDocument
Set rng = Selection.Range.Duplicate
rng.Expand wdWord
myRepl = Trim(rng.Text)

rng.Expand wdParagraph
rng.Collapse wdCollapseStart
rng.End = rng.End - 1
rng.Expand wdParagraph
sdfsd = rng.Text
myFandRs = ""
Do While Len(rng.Text) > 2
  myFind = Trim(rng.Words(3))
  If myFind = "=" Then myFind = Trim(rng.Words(5))
  myFandRs = myFandRs & myFind & "|" & myRepl & vbCr
  rng.Collapse wdCollapseStart
  rng.End = rng.End - 1
  rng.Expand wdParagraph
Loop
Set rng = Selection.Range.Duplicate
rng.Expand wdParagraph
rng.Collapse wdCollapseEnd
rng.Expand wdParagraph
Do While Len(rng.Text) > 2
  myFind = Trim(rng.Words(3))
  If myFind = "=" Then myFind = Trim(rng.Words(5))
  myFandRs = myFandRs & myFind & "|" & myRepl & vbCr
  rng.Collapse wdCollapseEnd
  rng.Expand wdParagraph
Loop

gottaFReditList = False
Set thisDoc = ActiveDocument
For Each myWnd In Application.Windows
  myWnd.Document.Activate
  Set rng = ActiveDocument.Content
  rng.End = rng.Start + 250
  If InStr(rng.Text, "|") > 0 Then
    gottaFReditList = True
    Exit For
  End If
Next myWnd
If gottaFReditList = False Then
  thisDoc.Activate
  MsgBox "Can't find a FRedit list file"
  Exit Sub
End If

Selection.Expand wdParagraph
Selection.Collapse wdCollapseEnd
Selection.TypeText Text:=myFandRs
thisDoc.Activate
End Sub