Sub InitialPullBack()
' Paul Beverley - Version 31.01.26
' Pulls author's trailing initial(s) (with/without periods/spaces) before surname

Set rng = Selection.Range.Duplicate
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[A-Z. \-]{2,}"
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute
  DoEvents
End With
rng.MoveEnd , 1
nextChar = Right(rng, 1)
If UCase(nextChar) <> nextChar Then
  rng.MoveEnd , -2
Else
  rng.MoveEnd , -1
End If
If InStr(" ," & vbCr, Right(rng, 1)) > 0 Then rng.MoveEnd , -1
Set rngDelete = rng.Duplicate
myInits = Trim(rng) & " "
Set rngNext = rng.Duplicate
rngNext.Collapse wdCollapseEnd
rngNext.MoveStart , 4
rngNext.Expand wdWord
rngNext.Collapse wdCollapseStart
With rngNext.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[A-Z][a-zA-Z]{2}"
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = ""
  .MatchWildcards = True
  .Execute
  DoEvents
End With
rngDelete.MoveStart , -1
fstChar = Left(rngDelete, 1)
If UCase(fstChar) <> LCase(fstChar) Then rngDelete.MoveStart , 1
rngDelete.Delete

Set rng = Selection.Range.Duplicate
rng.Expand wdWord
rng.InsertBefore Text:=myInits
rngNext.Collapse wdCollapseEnd
rngNext.Select
End Sub