Excel VBA宏修改求助：合并非连续单元格内容时保留原字体颜色

核心逻辑：原有代码仅拼接纯文本内容，未携带字体格式属性，本次修改通过Excel的Characters对象逐段复制原单元格的字体颜色，实现拼接后格式保留，和你提供的示例效果完全匹配。

完整修改后代码 #

Sub 拼接单元格保留字体颜色()
    Dim rngSource As Range, rngTarget As Range
    Dim cell As Range, rngArea As Range
    Dim startPos As Long, i As Long
    
    ' 处理用户取消选择的异常场景
    On Error Resume Next
    Set rngSource = Application.InputBox("选择要合并的单元格", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    Set rngTarget = Application.InputBox("选择目标单元格", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    
    ' 仅取目标区域的第一个单元格写入，避免多单元格冲突
    Set rngTarget = rngTarget.Cells(1)
    rngTarget.Clear ' 清空目标单元格原有内容和格式，避免干扰
    startPos = 1 ' 记录当前写入内容的起始位置
    
    ' 遍历所有选中的源单元格（兼容非连续选区）
    For Each rngArea In rngSource.Areas
        For Each cell In rngArea
            If Len(cell.Text) > 0 Then
                ' 先向目标单元格追加当前单元格内容+分隔空格
                rngTarget.Characters(startPos).Text = cell.Text & " "
                ' 逐字符复制原单元格的字体颜色（兼容单个源单元格内多色文字的场景）
                For i = 1 To Len(cell.Text)
                    rngTarget.Characters(startPos + i - 1, 1).Font.Color = cell.Characters(i, 1).Font.Color
                Next i
                ' 分隔空格默认匹配前一段文字的颜色，不需要可删除下行
                rngTarget.Characters(startPos + Len(cell.Text), 1).Font.Color = cell.Characters(Len(cell.Text), 1).Font.Color
                ' 更新下一段内容的起始位置
                startPos = startPos + Len(cell.Text) + 1
            End If
        Next cell
    Next rngArea
    
    ' 删除末尾多余的分隔空格
    If startPos > 1 Then
        rngTarget.Characters(startPos - 1, 1).Delete
    End If
End Sub

功能说明 #

• 兼容非连续单元格选择、单个单元格内多色文字的场景
• 分隔空格颜色默认和前一段文字保持一致，可根据需求调整为固定颜色
• 自动处理用户点击选择框「取消」的场景，不会报错

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