Sub WordCopierDown()
' Paul Beverley - Version 25.03.24
' Copies the word from the beginning of the selection to the end

' insertWord = True
insertWord = False
' i.e. overwrite the word

Set rng = Selection.Range.Duplicate
rng.Collapse wdCollapseStart
rng.Expand wdWord
Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
  rng.MoveEnd , -1
  DoEvents
Loop
goodWord = rng.Text
Set rng = Selection.Range.Duplicate
rng.Collapse wdCollapseEnd
rng.Expand wdWord
Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
  rng.MoveEnd , -1
  DoEvents
Loop
If insertWord = True Then
  rng.InsertAfter Text:=" " & goodWord
Else
  rng.Text = goodWord
End If
End Sub