Sub CaseNextWord()
' Paul Beverley - Version 16.04.24
' Changes case of initial letter of next word or selection

trackIt = True
showSingleTrack = True

' List of lowercase words *not* to be uppercased
lclist = " a an and as at by for from if in is it into of "
lclist = lclist & " on or that the to with "


' Or if you don't want this feature, use:
' lclist = ""

' If an area of text is selected
If Selection.End > Selection.Start Then
  Set rng = Selection.Range.Duplicate
  endNow = rng.End
  rng.Collapse wdCollapseStart
  rng.Expand wdWord
  startNow = rng.Start
  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
  rng.Start = startNow
  rng.Select
  Set rng = Selection.Range.Duplicate
  If LCase(rng.Text) = rng.Text Then
    For wd = 1 To rng.Words.Count
      myWd = rng.Words(wd)
      checkWd = " " & Trim(myWd) & " "
      If InStr(lclist, checkWd) = 0 Then
        ch = rng.Words(wd).Characters(1)
        rng.Words(wd).Characters(1) = UCase(ch)
      End If
    Next wd
  Else
    For wd = 1 To rng.Words.Count
      myWd = rng.Words(wd)
      If UCase(myWd) <> myWd Then
        ch = rng.Words(wd).Characters(1)
        rng.Words(wd).Characters(1) = LCase(ch)
      End If
    Next wd
  End If
  If trackIt = False Then
    Selection.Range.Revisions.AcceptAll
  End If
  If showSingleTrack = True Then
    myText = Selection
    Set rng = Selection.Range.Duplicate
    Selection.Range.Revisions.RejectAll
    rng.Text = myText
  End If
Else
' If no text is selected
  Selection.MoveStart wdWord
  Selection.MoveEnd , 1
  If LCase(Selection) = UCase(Selection) Then
    Selection.MoveStart wdWord
    Selection.MoveEnd , 1
  End If
  If LCase(Selection) = UCase(Selection) Then
    Selection.MoveStart wdWord
    Selection.MoveEnd , 1
  End If
  If LCase(Selection) = UCase(Selection) Then
    Selection.MoveStart wdWord
    Selection.MoveEnd , 1
  End If
  If trackIt = False Then
    Selection.Range.Case = wdToggleCase
    Selection.MoveRight Unit:=wdCharacter, Count:=1
  Else
    m = Selection.Text
    If UCase(m) = m Then
      Selection.Text = LCase(m)
    Else
      Selection.Text = UCase(m)
    End If
    Selection.Collapse wdCollapseEnd
  End If
End If
End Sub