Sub CopyToFReditListAlphabetic()
' Paul Beverley - Version 23.08.26
' Uses current text to form an item in an alphabetic FRedit list file

' Created for Jennifer Yankopolus, using | A, | B, | C... as headers

' To locate list file (not case sensitive)
' keyWord = "queries"
keyWord = "sheet"
keyWord = "FRedit"

' Add page and file name
addPage = False
addFilename = False
myPreText = " ("
myPostText = ")"
myMiddleText = ", p."

myName = Replace(ActiveDocument.Name, ".docx", "")
If addPage = True Then _
     myPageNum = Selection.Information(wdActiveEndAdjustedPageNumber)

' doSwitchNames = True
doSwitchNames = False

includeFormatting = False
' includeFormatting = True

' preText = ChrW(8226) & " "
preText = ""

wordsToAvoid = "switch"
' wordsToAvoid = "FRedit,switch"


' copyWholePara = True
copyWholePara = False

goBackToSource = False

Dim sourceText As Range
Set sourceDoc = ActiveDocument
wds = Split("," & LCase(wordsToAvoid), ",")

If Selection.Start = Selection.End Then
  If Selection = vbCr Then Selection.MoveLeft , 1
  If copyWholePara = True Then
    Selection.Expand wdParagraph
  Else
    Set rng = Selection.Range.Duplicate
    rng.Expand wdWord
    rng.MoveEnd wdWord, 1
    chkWd = rng.Words.last
    If chkWd = "-" Then
      rng.MoveEnd wdWord, 2
      chkWd = rng.Words.last
      If chkWd = "-" Then
        rng.MoveEnd wdWord, 1
      Else
        rng.MoveEnd wdWord, -1
      End If
    Else
      rng.MoveEnd wdWord, -1
    End If
    DoEvents
    Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
      rng.MoveEnd , -1
      DoEvents
    Loop
    rng.Select
  End If
Else
  Set rng = Selection.Range.Duplicate
  rng.Collapse wdCollapseEnd
  rng.MoveEnd , -1
  rng.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
    rng.MoveEnd , -1
    DoEvents
  Loop
  Selection.Collapse wdCollapseStart
  Selection.Expand wdWord
  Selection.Collapse wdCollapseStart
  rng.Start = Selection.Start
  rng.Select
End If

Set sourceText = Selection.Range.Duplicate
myText = preText & sourceText.Text
myInitial = UCase(Left(myText, 1))
myHeader = ChrW(124) & " " & myInitial & "^p"
Selection.Collapse wdCollapseEnd

gottaList = False
For Each FlistDoc In Application.Documents
  thisName = FlistDoc.Name
  nm = LCase(thisName)
  gottaList = False
  If InStr(nm, LCase(keyWord)) > 0 Then gottaList = True
  For i = 1 To UBound(wds)
    If InStr(nm, wds(i)) > 0 Then gottaList = False
  Next i
  If gottaList = True Then Exit For
Next FlistDoc

CR = vbCr: CR2 = CR & CR
If gottaList = False Then
  Beep
  myResponse = MsgBox("Can't find a list/stylesheet." & CR2 & _
       "Filename must include:  >" & keyWord & "<", vbExclamation _
       + vbOKOnly, "CopyToListAlphabetic")
  Exit Sub
End If

' Decide where to put the item
Set rng = FlistDoc.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myHeader
  .Wrap = wdFindStop
  .Forward = True
  .Replacement.Text = ""
  .MatchCase = True
  .MatchWildcards = False
  .Execute
  If .found = False Then
    Beep
    MsgBox "Can't find heading:  " & Left(myHeader, 3) & "   for your text:  " & myText
    Exit Sub
  End If
  DoEvents
End With

rng.Collapse wdCollapseEnd

rng.InsertAfter Text:=myText & ChrW(124) & myText & vbCr
rng.Revisions.AcceptAll
rng.Select
If goBackToSource = True Then
  sourceDoc.Activate
Else
  FlistDoc.Activate
End If
End Sub