Hey，我帮你调整这段VBA代码，刚好能实现你要的——把单元格里的删除线文本提取出来，拼接到单独的「备注」列，同时保留原单元格里的正常文本。

先说说修改思路：原代码是删除删除线文本，我们要反过来，把这些带删除线的内容捞出来存到备注列，还要保留原单元格的非删除线内容。另外，我做了灵活设置，让你可以自主选择备注列的位置。

下面是修改后的完整代码：

Sub ExtractStrikethroughToNotes()
    Dim xDataRg As Range, xNoteCell As Range
    Dim xCell As Range
    Dim xNormalStr As String, xStrikeStr As String
    Dim I As Long
    
    ' 让用户选择要处理的数据区域
    On Error Resume Next
    Set xDataRg = Application.InputBox("请选择要处理的数据区域：", "提取删除线文本", Selection.Address, , , , , 8)
    If xDataRg Is Nothing Then Exit Sub
    
    ' 让用户选择备注列的起始单元格（比如备注列的第一个单元格）
    Set xNoteCell = Application.InputBox("请选择备注列的起始单元格：", "指定备注列", , , , , , 8)
    If xNoteCell Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    ' 遍历每个数据单元格
    For Each xCell In xDataRg
        xNormalStr = ""
        xStrikeStr = ""
        
        ' 处理数值型单元格
        If IsNumeric(xCell.Value) Then
            If xCell.Font.Strikethrough Then
                ' 数值带删除线，把它放到备注，原单元格清空
                xStrikeStr = xCell.Value
                xCell.Value = ""
            End If
        Else
            ' 处理文本型单元格，逐字符检查格式
            For I = 1 To Len(xCell.Value)
                With xCell.Characters(I, 1)
                    If .Font.Strikethrough Then
                        xStrikeStr = xStrikeStr & .Text
                    Else
                        xNormalStr = xNormalStr & .Text
                    End If
                End With
            Next I
            ' 原单元格保留正常文本
            xCell.Value = xNormalStr
        End If
        
        ' 如果有提取到删除线文本，写入对应备注单元格
        If xStrikeStr <> "" Then
            ' 备注单元格如果已有内容，用分号分隔新增内容
            If xNoteCell.Offset(xCell.Row - xDataRg.Row, 0).Value <> "" Then
                xNoteCell.Offset(xCell.Row - xDataRg.Row, 0).Value = _
                xNoteCell.Offset(xCell.Row - xDataRg.Row, 0).Value & "; " & xStrikeStr
            Else
                xNoteCell.Offset(xCell.Row - xDataRg.Row, 0).Value = xStrikeStr
            End If
        End If
    Next xCell
    
    Application.ScreenUpdating = True
    MsgBox "提取完成！", vbInformation
End Sub

使用步骤： #

1. 打开你的Excel文件，按Alt + F11打开VBA编辑器
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」
3. 把上面的代码粘贴到模块窗口里
4. 回到Excel界面，按Alt + F8调出宏窗口，选择ExtractStrikethroughToNotes并点击「执行」
5. 按照提示依次选择数据区域和备注列的起始单元格，等待运行完成就行

代码说明： #

• 自动匹配数据行和备注行的对应关系，比如第2行的删除线文本会同步到备注列的第2行
• 精准提取单元格内部分带删除线的文本，原单元格只保留无删除线的正常内容
• 如果备注单元格已有内容，会用; 分隔新增内容，避免信息混乱
• 数值型单元格带删除线时，会完整提取到备注列，原单元格自动清空

内容的提问来源于stack exchange，提问作者Lei-Lonnie