Sub ExclamationMark()
' Paul Beverley - Version 14.02.26
' Makes adjacent words into exclamation mark break

newPunc = "! "
nextWordCapital = True


myQuotes = Chr(34) & Chr(39) & ChrW(8220) & ChrW(8216)
oldBits = ";:.,!?-" & ChrW(8212) & ChrW(8211)

Set rng = Selection.Range.Duplicate
rng.MoveEnd , 50
For i = 1 To rng.Characters.Count
  If InStr(oldBits, rng.Characters(i)) > 0 Then Exit For
Next i
If i > 50 Then
  Beep
  MsgBox "No relevant punctuation found."
  Exit Sub
End If

moveBack = (rng.Characters(i - 1) = " ")
rng.MoveStart , i - 1
If moveBack = True Then rng.MoveStart , -1
rng.Collapse wdCollapseStart

Do
  rng.MoveEnd , 1
  lastChar = rng.Characters.Last
  DoEvents
Loop Until UCase(lastChar) <> LCase(lastChar)

Set initChar = rng.Duplicate
initChar.Start = initChar.End - 1
rng.MoveEnd , -1
If nextWordCapital = True And UCase(lastChar) <> lastChar Then
  initChar.Text = UCase(lastChar)
End If
If nextWordCapital = False And LCase(lastChar) <> lastChar Then
  initChar.Text = LCase(lastChar)
End If
If InStr(myQuotes, rng.Characters.Last) Then rng.MoveEnd , -1
rng.Text = newPunc
initChar.Collapse wdCollapseStart
initChar.Select
End Sub