Sub CopyToListAlphabeticTable()
' Paul Beverley - Version 18.11.25
' Copies selected text into an alphabetic table

' N.B. Every table cell must have a title line + Enter
' To check, switch visible formatting on.

myTable = 1

myFormat = "6x2"
' myFormat = "12x2"
' myFormat = "13x2"
' myFormat = "26x1"

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

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

beepIfAlreadyListed = True

rowMax = Val(myFormat)
columnMax = Val(Right(myFormat, 1))

On Error GoTo ReportIt

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

CR = vbCr

If Selection.Start = Selection.End Then
  If Selection = CR Then Selection.MoveLeft , 1
  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
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 = sourceText.Text
Selection.Collapse wdCollapseEnd

gottaList = False
For Each sSheetDoc In Application.Documents
  thisName = sSheetDoc.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 sSheetDoc

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
myChar = UCase(Left(myText, 1))

' myFormat = "12x2"
If myFormat = "12x2" Then
  myJump = 2
  Select Case myChar
     Case "A", "B": myRow = 1
     Case "C", "D": myRow = 2
     Case "E", "F": myRow = 3
     Case "G", "H": myRow = 4
     Case "I", "J": myRow = 5
     Case "K", "L": myRow = 6
     Case "M", "N": myRow = 7
     Case "O", "P": myRow = 8
     Case "Q", "R": myRow = 9
     Case "S", "T": myRow = 10
     Case "U", "V": myRow = 11
     Case "W", "X", "Y", "Z": myRow = 12
  End Select
  If InStr("ACEGIKMOQSUW", myChar) > 0 Then
    myColumn = 1
  Else
    myColumn = 2
  End If
End If

' myFormat = "13x2"
If myFormat = "13x2" Then
  myJump = 2
  Select Case myChar
     Case "A", "B": myRow = 1
     Case "C", "D": myRow = 2
     Case "E", "F": myRow = 3
     Case "G", "H": myRow = 4
     Case "I", "J": myRow = 5
     Case "K", "L": myRow = 6
     Case "M", "N": myRow = 7
     Case "O", "P": myRow = 8
     Case "Q", "R": myRow = 9
     Case "S", "T": myRow = 10
     Case "U", "V": myRow = 11
     Case "W", "X": myRow = 12
     Case "Y", "Z": myRow = 13
  End Select
  If InStr("ACEGIKMOQSUWY", myChar) > 0 Then
    myColumn = 1
  Else
    myColumn = 2
  End If
End If

' myFormat = "6x2"
If myFormat = "6x2" Then
  myJump = 4
  Select Case myChar
     Case "A", "B", "C", "D": myRow = 1
     Case "E", "F", "G", "H": myRow = 2
     Case "I", "J", "K", "L": myRow = 3
     Case "M", "N", "O", "P": myRow = 4
     Case "Q", "R", "S", "T": myRow = 5
     Case "U", "V", "W", "X", "Y", "Z": myRow = 6
  End Select
  If InStr("ABEFIJMNQRUV", myChar) > 0 Then
    myColumn = 1
  Else
    myColumn = 2
  End If
End If

' myFormat = "26x1"
If myFormat = "26x1" Then
  myJump = 2
  myColumn = 1
  myRow = Asc(myChar) - 64
End If

Set rng = sSheetDoc.Tables(myTable).Cell(myRow, myColumn).Range
'If Len(rng) < myJump + 2 Then rng.InsertAfter Text:=CR
rng.MoveEnd , -1
allText = rng

' Check if it's already in the list
gotItAlready = (InStr(allText & CR, CR & myText & CR) > 0)

If gotItAlready = True Then
  If beepIfAlreadyListed = True Then Beep
  Exit Sub
End If

rng.MoveStart , myJump
myStart = rng.Start

rng.InsertBefore Text:=myText & CR
rng.Start = myStart
If myRow = rowMax And myColumn = columnMax Then rng.MoveEnd , -1

rng.Sort CaseSensitive:=False
rng.Font.Bold = False
Exit Sub

ReportIt:
If Err.Number = 5941 Then
  DoEvents
  Beep
  myPrompt = "Can't find table number: " & myTable & CR & CR & _
       "Please check the value of ""myTable"", near the beginning of the macro." _
       & CR & CR & "Or maybe the value of ""myFormat"" is not correct for your table."
  myResponse = MsgBox(myPrompt, vbQuestion + vbOKOnly, "CopyToListAlphabeticTable")
  Exit Sub
  Resume Next
Else
  On Error GoTo 0
  DoEvents
  Resume
End If
End Sub