Sub HyphenationToFRedit()
' Paul Beverley - Version 04.02.22
' Creates FRedit items from HyphenAlyse or PropernounAlyse files

makeListCaseInsensitive = True

useProperNounToFRedit = True

myList = "anti,cross,eigen,hyper,inter,meta,mid,multi," _
     & "non,over,post,pre,pseudo,quasi,semi,sub,super"

CR = vbCr
inAtable = Selection.Information(wdWithInTable)
If Not (inAtable) Then GoTo ProperNouns
wantOthers = (Selection.Start = Selection.End)
Set rng = Selection.Range.Duplicate
rng.Expand wdParagraph
' rng.Select
startCell = Replace(rng.Text, Chr(7), "")
startCell = Replace(startCell, Chr(13), "")
isBlank = (Len(startCell) < 3)
colNum = rng.Cells(1).ColumnIndex

rng.Expand wdRow
myCell = Split(Chr(7) & rng.Text, Chr(7))
For i = 1 To 4
  myText = Replace(myCell(i), vbCr, "")
'  myText = myCell(i)
  sdfgs = Len(myText)
  leadPos = InStr(myText, " . ")
  If leadPos > 0 Then
    myText = Left(myText, leadPos - 1)
  End If
  myCell(i) = myText
Next i

preWord = ""
If Len(myCell(1)) > 2 Then
  myText = myCell(1)
  spPos = InStr(myText, "-")
  preWord = Left(myText, spPos - 1)
  postWord = Mid(myText, spPos + 1)
End If
myText = myCell(2)
If preWord = "" And myText > "" Then
  spPos = InStr(myText, " ")
  preWord = Left(myText, spPos - 1)
  postWord = Mid(myText, spPos + 1)
End If
myText = myCell(4)
If preWord = "" And myText > "" Then
  spPos = InStr(myText, ChrW(8211))
  preWord = Left(myText, spPos - 1)
  postWord = Mid(myText, spPos + 1)
End If
If preWord = "" Then
  myList = "," & myList & ","
  myText = myCell(3)
  For i = 3 To 6
    preWord = Left(myText, i)
    If InStr(myList, "," & preWord & ",") > 0 Then Exit For
  Next i
  If i > 6 Then
    Beep
    MsgBox ("Can't find this prefix")
    Exit Sub
  End If
  postWord = Replace(myText, preWord, "")
End If

Select Case colNum
  Case 1: myJoin = "-"
  Case 2: myJoin = " "
  Case 3: myJoin = ""
  Case 4: myJoin = ChrW(8211)
  Case Else
    Beep
    MsgBox ("Something has gone wrong.")
    Exit Sub
End Select

targetWord = preWord & myJoin & postWord
oneWord = preWord & postWord
hyphWord = preWord & "-" & postWord
twoWords = preWord & " " & postWord
dashWords = preWord & ChrW(8211) & postWord

myFRitem = ""
If makeListCaseInsensitive = True Then
  cs = ChrW(172)
Else
  cs = ""
End If

If wantOthers Then
  If targetWord = oneWord Then
    myFRitem = cs & twoWords & ChrW(124) & oneWord & CR & _
         cs & hyphWord & ChrW(124) & oneWord & CR & _
         cs & dashWords & ChrW(124) & oneWord & CR
  End If
  If targetWord = twoWords Then
    myFRitem = cs & oneWord & ChrW(124) & twoWords & CR & _
         cs & hyphWord & ChrW(124) & twoWords & CR & _
         cs & dashWords & ChrW(124) & twoWords & CR
  End If
  If targetWord = hyphWord Then
    myFRitem = cs & twoWords & ChrW(124) & hyphWord & CR & _
         cs & oneWord & ChrW(124) & hyphWord & CR & _
         cs & dashWords & ChrW(124) & hyphWord & CR
  End If
  If targetWord = dashWords Then
    myFRitem = cs & twoWords & ChrW(124) & dashWords & CR & _
         cs & oneWord & ChrW(124) & dashWords & CR & _
         cs & hyphWord & ChrW(124) & dashWords & CR
  End If
Else
  If targetWord = oneWord Then
    If myCell(1) > "" Then
      myFRitem = myFRitem & cs & hyphWord & ChrW(124) & oneWord & CR
    End If
    If myCell(2) > "" Then
      myFRitem = myFRitem & cs & twoWords & ChrW(124) & oneWord & CR
    End If
    If myCell(4) > "" Then
      myFRitem = myFRitem & cs & dashWords & ChrW(124) & oneWord & CR
    End If
    If InStr(myFRitem, ChrW(124)) = 0 Then
      myFRitem = cs & hyphWord & ChrW(124) & oneWord & CR
    End If
  End If
  If targetWord = twoWords Then
    If myCell(1) > "" Then
      myFRitem = cs & hyphWord & ChrW(124) & twoWords & CR
    End If
    If myCell(3) > "" Then
      myFRitem = myFRitem & cs & oneWord & ChrW(124) & twoWords & CR
    End If
    If myCell(4) > "" Then
      myFRitem = myFRitem & cs & dashWords & ChrW(124) & twoWords & CR
    End If
    If InStr(myFRitem, ChrW(124)) = 0 Then
      myFRitem = cs & hyphWord & ChrW(124) & twoWords & CR
    End If
  End If
  If targetWord = hyphWord Then
    If myCell(2) > "" Then
      myFRitem = cs & twoWords & ChrW(124) & hyphWord & CR
    End If
    If myCell(3) > "" Then
      myFRitem = cs & oneWord & ChrW(124) & hyphWord & CR
    End If
    If myCell(4) > "" Then
      myFRitem = cs & dashWords & ChrW(124) & hyphWord & CR
    End If
    If InStr(myFRitem, ChrW(124)) = 0 Then
      myFRitem = cs & oneWord & ChrW(124) & hyphWord & CR
    End If
  End If
End If
If myFRitem = "" Then
  Beep
  MsgBox ("For prefixes, place the cursor in a blank cell.")
Else
  gottaFReditList = False
  Set thisDoc = ActiveDocument
  For Each myWnd In Application.Windows
    myWnd.Document.Activate
    Set rng = ActiveDocument.Content
  ' Finding a '|' in the first 250 characters means it's a list
    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
  If Len(Selection) > 1 Then Selection.Collapse wdCollapseEnd
  Selection.TypeText myFRitem
End If
thisDoc.Activate
Exit Sub

ProperNouns:
If useProperNounToFRedit = True Then
  Call ProperNounToFRedit
Else
  Selection.Expand wdParagraph
  Selection.Collapse wdCollapseStart
  Selection.Expand wdWord
  myWord = Trim(Selection)
  myFRitem = myWord & "|" & myWord & vbCr
  
  gottaFReditList = False
  Set thisDoc = ActiveDocument
  For Each myWnd In Application.Windows
    myWnd.Document.Activate
    Set rng = ActiveDocument.Content
  ' Finding a '|' in the first 250 characters means it's a list
    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
  If Len(Selection) > 1 Then Selection.Collapse wdCollapseEnd
  Selection.TypeText myFRitem
  thisDoc.Activate
End If
End Sub