Sub EmDashUnspaced()
' Paul Beverley - Version 14.06.21
' Removes punctuation, adds unspaced em dash and lowercases next char

newBit = ChrW(8212)

myPunct = "!?,.:;"

myQuotes = Chr(34) & Chr(39) & ChrW(8220) & ChrW(8216)
Selection.Collapse wdCollapseEnd
Do
  Selection.MoveRight 1
  DoEvents
Loop Until (InStr(myPunct, Selection) > 0) Or Selection = " "

myStart = Selection.Start
If Selection = ChrW(8217) Then myStart = myStart + 1
Do
  Selection.MoveRight 1
  DoEvents
Loop Until LCase(Selection) <> UCase(Selection) Or Asc(Selection) = 1

myEnd = Selection.Start
Set rng = ActiveDocument.Content
rng.End = myEnd
rng.Start = myStart
wasMiddle = rng
lastChar = Right(rng, 1)
If LCase(Selection) <> Selection Then
' It needs lowercasing
  Selection.Start = Selection.Start - 1
  preChar = Selection
  Selection.MoveStart 1
  Selection.MoveEnd 1
  newLetter = LCase(Selection)
  If InStr(myQuotes, preChar) > 0 Then
    Selection.Delete
    Selection.TypeText newLetter
    Selection.End = myEnd - 1
  Else
    newBit = newBit & newLetter
  End If
  Selection.Start = myStart
End If
Selection.Start = myStart
Selection.Delete
Selection.TypeText newBit
Selection.MoveRight count:=1
End Sub