如何通过VBA实现MS Word段落复制粘贴时保留原始格式

你当前的代码使用String类型的datainbtw存储Range.Text返回的纯文本内容，所有粗体、斜体、下划线等字符格式，以及图片等内嵌元素都会在转纯文本的过程中被直接剥离，这是格式丢失的根本原因。

我们将存储内容的变量从字符串改为Range类型，通过Word原生的FormattedText接口传递带格式的内容，即可完整保留所有原始格式。修改后的代码如下：

Sub replacemissing3()
    Dim myarray As Variant
    Dim i As Integer
    Dim line_text As String
    ' 原字符串类型改为Range类型，存储带完整格式的内容片段
    Dim datainbtw As Range
    Dim missing_image As InlineShape
    Dim check As Boolean
    Dim tempRange As Range
    
    check = False
    Set datainbtw = Nothing
    i = 0
    myarray = Array("ØQ:", "ØQuestion:", "ØQuestionHindi:", "ØOption:", "ØOptionHindi:")

    For Each singleline In ActiveDocument.Paragraphs
        line_text = singleline.Range.Text

        If check Then
            If Not InStr(singleline.Range.Text, "Ø") And Trim(singleline.Range.Text) <> "" Then
                ' 合并符合条件的段落范围，完整保留格式和内嵌元素
                If datainbtw Is Nothing Then
                    Set datainbtw = singleline.Range.Duplicate
                Else
                    Set datainbtw = ActiveDocument.Range(datainbtw.Start, singleline.Range.End)
                End If
                
                ' 原有图片处理逻辑适配
                If singleline.Range.ShapeRange.Count > 0 Then
                    Set missing_image = singleline.Range.ShapeRange(1).ConvertToInlineShape
                    datainbtw.InsertAfter "Ømissingimage"
                End If

                If singleline.Range.InlineShapes.Count > 0 Then
                    Set missing_image = singleline.Range.InlineShapes(1)
                    datainbtw.InsertAfter "Ømissingimage"
                End If

            End If
        End If

        ' 字段匹配逻辑保留
        If InStr(line_text, "ØQ:") Then
            line_text = "ØQ:"
        End If
        If InStr(line_text, "ØQuestion:") Then
            line_text = "ØQuestion:"
        End If
        If InStr(line_text, "ØQuestionHindi:") Then
            line_text = "ØQuestionHindi:"
        End If
        If InStr(line_text, "ØOption:") Then
            line_text = "ØOption:"
        End If
        If InStr(line_text, "ØOptionHindi:") Then
            line_text = "ØOptionHindi:"
        End If
     
        line_text = Trim(line_text)

        If InStr(line_text, "Ø") = 1 Then

            If InStr(singleline.Range.Text, "Ømissingimage") Then
                missing_image.Select
                Selection.Copy
                singleline.Range.PasteSpecial
                GoTo lbl1
            End If

            If line_text <> myarray(i) Then
                ' 先插入补全的字段名和换行
                singleline.Range.Text = myarray(i) & vbNewLine
                ' 追加带格式的内容片段，不丢失格式
                If Not datainbtw Is Nothing Then
                    Set tempRange = singleline.Range.Duplicate
                    tempRange.Collapse wdCollapseEnd
                    tempRange.FormattedText = datainbtw.FormattedText
                End If
                i = i - 1
            End If

            If myarray(i) = "ØOptionHindi:" Then
                i = -1
            End If
            i = i + 1
lbl1:
            Set datainbtw = Nothing
            check = True
        End If

    Next singleline
 
End Sub

• 变量类型调整：将datainbtw从字符串改为Range类型，可承载段落的全部格式信息、内嵌图片等元素
• 内容拼接逻辑：不再使用字符串拼接，而是通过范围合并的方式收集符合要求的内容，完整保留所有格式
• 内容插入逻辑：替换原来直接修改Range.Text的操作，先插入补全的字段名，再通过FormattedText属性把带格式的内容追加到对应位置，避免格式丢失
• 原有逻辑兼容：缺失字段校验、图片标记逻辑全部保留，仅做了适配调整，不会影响原有功能

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