编写实现改良式合并格式粘贴的Word VBA代码需求

我需要编写一段Word VBA代码，实现以下功能：

• 粘贴一段首尾带引号、内部包含斜体/粗体等格式的文本字符串
• 将这段带引号的文本移到剩余文本末尾的括号中
• 保留原文本的强调格式（斜体、粗体等），同时适配目标段落的样式（类似改良版「合并格式」粘贴）
• 最终光标定位到粘贴文本的末尾

原始粘贴内容 #

"This "is" the "text," which I want to copy." John Doe v. Doe, 470 U.S. 99 (1999)
（注：用*和__模拟原文本的斜体、粗体格式）

期望效果 #

John Doe v. Doe, 470 U.S. 99 (1999) ("This "is" the "text," which I want to copy.")

我自行编写的代码未能达到预期效果：

Sub ExampleCode()
Application.ScreenUpdating = False
Dim RngA As range, RngB As range, StrTmp As String
Set RngA = Selection.range
With RngA
.Paste
Do While .Characters.Last Like "[ " & Chr(11) & vbCr & "]"
.End = .End - 1
Loop
StrTmp = .Text
.Text = ""
.InsertBefore StrTmp
.MoveStartUntil Chr(34), wdBackward
.MoveEndUntil Chr(34), wdBackward
.MoveEndUntil Chr(34), wdBackward
.MoveEndUntil Chr(34), wdBackward
.MoveEndUntil Chr(34), wdBackward
Set RngB = .Duplicate
.Collapse wdCollapseStart
.Text = " (" & RngB.Text & ")"
.FormattedText = RngB.FormattedText
RngB.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub

Sub PasteAndFormatQuote()
    Application.ScreenUpdating = False
    Dim pasteRange As Range, quoteRange As Range, targetRange As Range
    Dim firstQuotePos As Long, lastQuotePos As Long
    
    ' 用合并格式粘贴，适配目标样式同时保留原格式
    Selection.PasteAndFormat wdFormatMergeFormat
    
    Set pasteRange = Selection.Range
    ' 清理末尾多余的空白、换行符
    Do While pasteRange.Characters.Last Like "[ " & Chr(11) & vbCrLf & vbCr & vbTab & "]"
        pasteRange.End = pasteRange.End - 1
    Loop
    
    ' 定位第一个双引号
    firstQuotePos = InStr(pasteRange.Text, Chr(34))
    If firstQuotePos = 0 Then GoTo Cleanup ' 无引号直接结束
    
    ' 定位最后一个双引号
    lastQuotePos = InStrRev(pasteRange.Text, Chr(34))
    If lastQuotePos <= firstQuotePos Then GoTo Cleanup ' 引号不配对直接结束
    
    ' 定义带引号的格式文本范围
    Set quoteRange = pasteRange.Duplicate
    quoteRange.Start = pasteRange.Start + firstQuotePos - 1
    quoteRange.End = pasteRange.Start + lastQuotePos
    
    ' 定义引号外的剩余文本范围并清理空白
    Set targetRange = pasteRange.Duplicate
    targetRange.End = quoteRange.Start - 1
    targetRange.Trim
    
    ' 重新拼接内容：剩余文本 + 空格 + ( + 带格式的引号文本 + )
    pasteRange.Text = targetRange.Text & " ("
    pasteRange.Collapse wdCollapseEnd
    pasteRange.FormattedText = quoteRange.FormattedText
    pasteRange.Collapse wdCollapseEnd
    pasteRange.Text = ")"
    
    ' 光标定位到内容末尾
    pasteRange.Collapse wdCollapseEnd
    pasteRange.Select
    
Cleanup:
    Application.ScreenUpdating = True
End Sub

代码说明 #

1. 粘贴逻辑：使用PasteAndFormat wdFormatMergeFormat实现「合并格式」粘贴，自动适配目标段落样式的同时保留原文本的斜体、粗体格式
2. 引号定位：用InStr和InStrRev精准定位首尾双引号，替代原代码中重复的MoveEndUntil，逻辑更稳定可靠
3. 格式保留：拆分带格式的引号文本和剩余文本，通过FormattedText属性拼接，避免纯文本替换丢失样式
4. 异常处理：增加无引号、引号不配对的判断，避免代码报错
5. 光标定位：最后将光标移到粘贴内容的末尾，满足需求

内容的提问来源于stack exchange，提问作者broncos15