如何删除单元格删除线且保留字体颜色、加粗、斜体格式？

问题描述 #

我的单元格中存在部分文本带有删除线，为提升可读性，我希望移除这些删除线。我找到了一段VBA代码，但它无法保留字体颜色及加粗格式，能否协助我修改这段代码？补充说明：所有含文本的单元格均以'开头。

原代码（存在格式丢失问题） #

Sub DelStrikethroughText()
    Dim xRg As Range, xCell As Range
    Dim xStr As String
    Dim I As Long
    On Error Resume Next
    Set xRg = Application.InputBox("Please select range：", "KuTools For Excel", Selection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Application.ScreenUpdating = Fase
        For Each xCell In xRg
            If IsNumeric(xCell.Value) And xCell.Font.Strikethrough Then
                xCell.Value = ""
            ElseIf Not IsNumeric(xCell.Value) Then
                For I = 1 To Len(xCell)
                    With xCell.Characters(I, 1)
                        If Not .Font.Strikethrough Then
                            xStr = xStr & .Text
                        End If
                    End With
                Next
                xCell.Value = xStr
                xStr = ""
            End If
        Next
    Application.ScreenUpdating = True
End Sub

修改后的代码（保留字体颜色与加粗格式） #

Sub DelStrikethroughText_PreserveFormat()
    Dim xRg As Range, xCell As Range
    Dim I As Long, charPos As Long
    Dim charText As String
    Dim charColor As Long
    Dim charBold As Boolean
    
    On Error Resume Next
    Set xRg = Application.InputBox("请选择目标区域：", "移除删除线文本", Selection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    For Each xCell In xRg
        ' 跳过空单元格
        If xCell.Value = "" Then GoTo NextCell
        
        ' 处理数值型且整单元格带删除线的情况
        If IsNumeric(xCell.Value) And xCell.Font.Strikethrough Then
            xCell.Value = ""
            GoTo NextCell
        End If
        
        ' 处理文本型单元格（含以'开头的文本）
        If Not IsNumeric(xCell.Value) Then
            charPos = 0
            ' 先记录原单元格内容（避免清空后丢失原字符数据）
            Dim originalText As String
            originalText = xCell.Value
            ' 清空单元格内容
            xCell.ClearContents
            ' 遍历原文本每个字符
            For I = 1 To Len(originalText)
                With xCell.Characters(I, 1)
                    .Text = Mid(originalText, I, 1)
                    ' 仅保留无删除线的字符并恢复格式
                    If Not .Font.Strikethrough Then
                        charText = .Text
                        charColor = .Font.Color
                        charBold = .Font.Bold
                        
                        ' 将字符添加到单元格，并恢复格式
                        charPos = charPos + 1
                        xCell.Characters(charPos, 1).Text = charText
                        With xCell.Characters(charPos, 1).Font
                            .Color = charColor
                            .Bold = charBold
                        End With
                    End If
                End With
            Next I
        End If
        
NextCell:
    Next xCell
    
    Application.ScreenUpdating = True
End Sub

关键修改说明 #

• 修复原代码拼写错误：Application.ScreenUpdating = Fase 改为 False
• 不再直接替换单元格值，改为先记录原内容，清空后逐个插入保留的字符并恢复其字体颜色和加粗属性
• 适配以'开头的文本单元格：这类单元格属于文本格式，遍历字符时自动兼容前缀标记
• 增加空单元格跳过逻辑，提升执行效率

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