我太懂这种卡顿崩溃的痛苦了！之前帮不少人解决过类似的问题，你的原VBA代码大概率是踩了几个性能大坑——比如频繁用Selection对象、没关闭屏幕刷新、遍历逻辑低效。下面给你一套优化后的实现方案，同时拆解关键优化点：

一、原代码卡顿的核心原因 #

• 依赖Selection对象：这是交互式UI对象，每一次操作都会触发Word的界面刷新，大文档里直接拉垮性能
• 未禁用屏幕刷新和事件：Word会实时更新界面、触发各种事件，拖慢代码执行速度
• 遍历逻辑有问题：比如正向遍历字符导致索引错乱，或者没处理页眉/页脚/文本框这类StoryRange区域

二、高效稳定的优化版VBA代码 #

Sub FakeFormattingToRealTrackChanges()
    Dim doc As Document
    Dim storyRange As Range
    Dim char As Range
    Dim i As Long
    Dim originalScreenUpdating As Boolean
    Dim originalEnableEvents As Boolean
    Dim backupPath As String

    ' ========== 前置准备：备份文档+关闭UI刷新 ==========
    Set doc = ActiveDocument
    ' 自动创建备份，防止转换出错
    backupPath = doc.Path & "\Backup_" & Format(Now(), "YYYYMMDD_HHMMSS") & ".docx"
    doc.SaveCopyAs backupPath

    ' 保存原状态，关闭屏幕刷新和事件（性能提升核心）
    originalScreenUpdating = Application.ScreenUpdating
    originalEnableEvents = Application.EnableEvents
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' 开启真实修订模式，后续修改会自动标记
    doc.TrackRevisions = True

    ' ========== 遍历所有文档区域（正文/页眉/页脚/文本框等） ==========
    For Each storyRange In doc.StoryRanges
        Do
            ' 反向遍历字符：避免删除字符后索引错乱
            For i = storyRange.Characters.Count To 1 Step -1
                Set char = storyRange.Characters(i)

                ' --------------------------
                ' 这里根据你的假修订规则修改判断逻辑
                ' 示例规则：
                ' 1. 删除线格式 = 标记为修订删除
                ' 2. 红色字体 = 标记为修订新增（恢复默认格式后自动记录为修改）
                ' --------------------------
                If char.Font.StrikeThrough = True Then
                    ' 直接删除，自动触发修订删除标记
                    char.Delete
                ElseIf char.Font.Color = wdColorRed Then
                    ' 恢复默认字体颜色，自动触发修订修改标记
                    char.Font.Color = wdColorAutomatic
                End If
            Next i

            ' 处理嵌套的StoryRange（比如文本框、批注内的内容）
            Set storyRange = storyRange.NextStoryRange
        Loop Until storyRange Is Nothing
    Next storyRange

    ' ========== 恢复原状态+结束提示 ==========
    Application.ScreenUpdating = originalScreenUpdating
    Application.EnableEvents = originalEnableEvents
    MsgBox "假修订转换完成！备份文件已保存至：" & vbCrLf & backupPath, vbInformation
End Sub

三、关键优化点解析 #

• 强制关闭UI刷新与事件：这是提升速度最明显的操作——Word不会实时刷新界面、触发多余事件，代码执行速度能提升数倍
• 反向遍历字符：如果正向遍历，删除一个字符后后面的字符索引会全部前移，导致跳过内容；反向遍历从最后一个字符往前处理，完全避免这个问题
• 用Range替代Selection：Range是后台对象，操作不会触发UI交互，性能远优于Selection
• 遍历所有StoryRange：确保页眉、页脚、文本框等所有隐藏区域的假修订都被处理，原代码大概率遗漏了这些区域
• 自动备份文档：转换前自动生成时间戳备份，再也不怕代码出错搞丢原文档

四、针对超大文档的额外优化 #

如果你的文档是几百页的超大文件，可以再加两个优化：

• 批量处理连续格式：比如先找到一整段连续的删除线文本，批量删除，减少循环次数（比单个字符处理快很多）
• 分段处理+阶段性刷新：按文档节分段处理，每处理完一节短暂恢复屏幕刷新，避免Word长时间无响应被系统判定为崩溃

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