VBA代码如下：

Sub AddPinYin()

Application.ScreenUpdating = False

Dim tintTreatingCount As Integer

Dim tstrCharA As String

Dim tlngCurPos As Long

Dim tintA As Integer

Selection.WholeStory

tstrText = Selection.Text

tintTextLength = Selection.Characters.Count

tintlinestart = 1

tintTreatingCount = 0

Selection.GoTo What:=wdGoToHeading, Which:=wdGoToAbsolute, Count:=1

Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend

Selection.GoTo What:=wdGoToHeading, Which:=wdGoToAbsolute, Count:=1

For tintloopx = 1 To tintTextLength

tlngCurPos = Selection.MoveRight(unit:=wdCharacter, Count:=1, Extend:=wdExtend)

tstrCharA = Right(Selection.Text, 1)

If AscW(tstrCharA) < 255 And AscW(tstrCharA) > -255 Then

If tintTreatingCount > 0 Then

tintA = Len(Selection.Text)

SendKeys "{enter}", 2

Application.Run MacroName:="FormatPhoneticGuide"

Selection.MoveRight unit:=wdCharacter, Count:=tintA

tintTreatingCount = 0

End If

Else

tintTreatingCount = tintTreatingCount + 1

End If

Next

'加空格

Selection.GoTo What:=wdGoToHeading, Which:=wdGoToAbsolute, Count:=1

For tintloopx = 1 To tintTextLength

Selection.MoveRight unit:=wdCharacter, Count:=1

Selection.TypeText Text:=" "

Next

Application.ScreenUpdating = True

MsgBox "任务成功完成"

End Sub

源代码在这，我稍微改了几句：如何为整篇word文档加拼音标注 - 拍拍猫脑 - 博客园​www.cnblogs.com

我分离出了单独逐字加空格的代码：

Sub XX()

Application.ScreenUpdating = False

Dim tintTreatingCount As Integer

Dim tstrCharA As String

Dim tlngCurPos As Long

Dim tintA As Integer

Selection.WholeStory

tstrText = Selection.Text

tintTextLength = Selection.Characters.Count

Selection.GoTo What:=wdGoToHeading, Which:=wdGoToAbsolute, Count:=1

For tintloopx = 1 To tintTextLength

Selection.MoveRight unit:=wdCharacter, Count:=1

Selection.TypeText Text:=" "

Next

Application.ScreenUpdating = True

End Sub

这篇也可以参考：Word自定义宏实现全文拼音标注 - CSDN博客​blog.csdn.net