Sub SelectWord()
' Paul Beverley - Version 24.05.24
' Selects current word, and then those before it

If Selection.Start = Selection.End Then
  Selection.Expand wdWord
  lenNow = Len(Selection)
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  If Right(Selection, 2) = ChrW(8217) & "s" Then
    Selection.MoveEnd , -2
  End If
  If Len(Selection) <> lenNow Then Exit Sub
  Set rng = Selection.Range.Duplicate
  rng.Collapse wdCollapseStart
  rng.MoveStart , -1
  preChar = rng.Text
  If LCase(preChar) = UCase(preChar) Then Exit Sub
End If

Selection.MoveStart , -1
preChar = Left(Selection, 1)
Selection.MoveStart , 1

If preChar = "," Or preChar = " " Then
  Selection.MoveStart , -1
  Exit Sub
End If

Selection.MoveStart wdWord, -1
Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
  Selection.MoveEnd , -1
  DoEvents
Loop
End Sub