如何优化VBA加载JSON及Word文档符号精准替换流程？

我拥有两个存储符号及其对应替换内容的JSON文件：

• QCF_.json
• QCF2.json

需求是在Word活动文档中精准查找特定符号，替换为JSON文件中的对应内容，预设流程为：

1. 遍历活动文档的每个单词，收集关联的字体名与符号；
2. 执行Find/Replace完成符号替换。

现有实现存在两个问题：

• 通过Word打开JSON文件加载内容，耗时极长；
• 尝试用FileSystemObject读取JSON速度快，但符号匹配替换功能失效。

需要优化以下两个核心环节：

1. JSON文件的读取加载；
2. 文档符号的查找替换。

现有实现代码 #

主替换函数

Sub Find_Replace_Precise_Method()
    'Latest Improved
    Dim StartTime As Double, SecondsElapsed As Double
    Dim AD As Document
    Dim W As Range
    Dim Font, Sym, FN
    Dim QCFs
'   Load jSon Function
    If Load_jSon = False Then
        Application.StatusBar = "   There was an error while loading jSon!!!"
        Exit Sub
    End If
'   Time Calculation
    Application.ScreenUpdating = False
    StartTime = Timer
'   Collection of fonts as well as symbols
    Set AD = ActiveDocument
    Set QCFs = New Scripting.Dictionary
    For Each W In AD.Words
        If QCFs.Exists(W.Font.Name & " " & Trim(W.Text)) = False And InStr(1, W.Font.Name, "QCF") > 0 Then
            If Len(Trim(W.Text)) > 1 Then
                myF = W.Characters.First.Font.Name
                With W.Find
                    .Text = "(?)"
                    .Replacement.Text = "\1" & " "
                    .MatchWildcards = True
                    .Execute Replace:=wdReplaceAll
                End With
                For Each C In W.Words
                    C.Font.Name = myF
                    QCFs(myF & " " & Trim(C.Text)) = x
                Next
            Else
                x = x + 1
                QCFs(W.Font.Name & " " & Trim(W.Text)) = x
            End If
        End If
    Next
Application.StatusBar = x & " " & Round(Timer - StartTime, 2)
x = 0
'   Find Replace
    For Each FontName In QCFs
            FN = Split(FontName)(0)
            Sym = Split(FontName)(1)
        If InStr(1, FontName, "QCF_") > 0 Then
            Font = Font_(FN)(Sym)
        Else
            Font = Font2(FN)(Sym)
        End If
        If Not Font = "" Then
            With AD.Range.Find
                .Font.Name = FN
                .Text = Sym
                .Replacement.Text = Font
                .Execute Replace:=wdReplaceAll
            End With
        End If
        x = x + 1
    Next FontName
    SecondsElapsed = Round(Timer - StartTime, 2) / 60
    MsgBox "Time Taken (min): " & vbTab & SecondsElapsed & vbCr & "Precise Replaces: " & vbTab & x, vbOKOnly + vbInformation
End Sub

原JSON加载函数

Function Load_jSon() As Boolean
    Dim oDoc As Word.Document
    If Not Font_ Is Nothing And Not Font2 Is Nothing Then
        Load_jSon = True
        Exit Function
    End If
    JJ = Split("QCF_.json QCF2.json")
    For Each j In JJ
        Application.StatusBar = "   Checking jSon ...   " & j
        jSONpath = ActiveDocument.Path & Application.PathSeparator & j
        If Dir(jSONpath) = "" Then
            MsgBox j & " is NOT present in the same Folder, please! place the JSON file and then run again" _
            & vbCr & jSONpath, vbOKOnly + vbCritical
            Load_jSon = False
            Exit Function
        End If
    Next j
    For Each j In JJ
        Application.StatusBar = "   Processing JSON ...   " & j
        Set oDoc = Documents.Open(ActiveDocument.Path & Application.PathSeparator & j, Visible:=False)
        With oDoc
            JsonText = .Range.Text
            .Close
        End With
        Application.StatusBar = "   Parsing JSON .....   " & j
        Set jSon = JsonConverter.ParseJson(JsonText)
        If Not jSon.Exists("fonts") Then
            MsgBox "Wrong JSON!!!" & vbCr & j, vbOKOnly + vbCritical
            Load_jSon = False
            Exit Function
        End If
        If j = "QCF_.json" Then
            Set Font_ = jSon("fonts")
        Else
            Set Font2 = jSon("fonts")
        End If
        Load_jSon = True
    Next j
End Function

一、JSON读取加载优化 #

原代码通过Word打开JSON文件读取内容是加载缓慢的核心原因，改用FileSystemObject直接读取文本文件，同时处理UTF-8编码的BOM问题（避免解析时出现无效字符），确保JSON内容完整准确。

优化后的Load_jSon函数：

' 需提前引用 Microsoft Scripting Runtime
Function Load_jSon() As Boolean
    Dim FSO As New FileSystemObject
    Dim JsonTS As TextStream
    Dim JsonText As String
    Dim j As Variant, JJ As Variant
    Dim jSon As Object
    
    ' 若已加载则直接返回
    If Not Font_ Is Nothing And Not Font2 Is Nothing Then
        Load_jSon = True
        Exit Function
    End If
    
    JJ = Split("QCF_.json QCF2.json")
    
    ' 先检查文件是否存在
    For Each j In JJ
        Application.StatusBar = "   检查JSON文件...   " & j
        If Not FSO.FileExists(ActiveDocument.Path & Application.PathSeparator & j) Then
            MsgBox j & " 未在当前文件夹中，请放置文件后重试" & vbCr & ActiveDocument.Path & Application.PathSeparator & j, vbOKOnly + vbCritical
            Load_jSon = False
            Exit Function
        End If
    Next j
    
    ' 读取并解析JSON
    For Each j In JJ
        Application.StatusBar = "   读取JSON文件...   " & j
        Set JsonTS = FSO.OpenTextFile(ActiveDocument.Path & Application.PathSeparator & j, ForReading, False, TristateTrue)
        JsonText = JsonTS.ReadAll
        JsonTS.Close
        
        ' 移除UTF-8 BOM（如果存在）
        If Left(JsonText, 3) = ChrW(&HFEFF) Then
            JsonText = Mid(JsonText, 4)
        End If
        
        Application.StatusBar = "   解析JSON...   " & j
        Set jSon = JsonConverter.ParseJson(JsonText)
        
        If Not jSon.Exists("fonts") Then
            MsgBox "JSON格式错误！" & vbCr & j, vbOKOnly + vbCritical
            Load_jSon = False
            Exit Function
        End If
        
        If j = "QCF_.json" Then
            Set Font_ = jSon("fonts")
        Else
            Set Font2 = jSon("fonts")
        End If
    Next j
    
    Load_jSon = True
End Function

二、文档查找替换优化 #

原代码遍历所有单词效率低下，且拆分多字符符号的逻辑易出错。优化点：

1. 直接用Find方法批量定位QCF字体的字符，避免遍历冗余内容；
2. 用|作为字体名与符号的分隔符，避免空格导致的拆分错误；
3. 关闭更多Word后台功能（拼写检查、自动更正等）进一步提速。

优化后的主函数：

Sub Find_Replace_Precise_Method()
    Dim StartTime As Double, SecondsElapsed As Double
    Dim AD As Document
    Dim QCFs As New Scripting.Dictionary
    Dim FontName As Variant, FN As String, Sym As String, ReplaceText As String
    Dim rng As Range
    
    ' 加载JSON
    If Not Load_jSon() Then
        Application.StatusBar = "JSON加载出错！"
        Exit Sub
    End If
    
    ' 关闭后台操作提速
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveDocument.CheckSpellingAsYouType = False
    ActiveDocument.CheckGrammarAsYouType = False
    
    StartTime = Timer
    Set AD = ActiveDocument
    
    ' 收集QCF字体的所有符号（用Find批量查找）
    Set rng = AD.Content
    With rng.Find
        .ClearFormatting
        .Font.Name = "*QCF*"
        .Text = ""
        .MatchWildcards = True
        .Wrap = wdFindStop
        
        Do While .Execute
            ' 确保是有效符号（避免空白）
            If Len(Trim(rng.Text)) > 0 Then
                Dim key As String
                key = rng.Font.Name & "|" & Trim(rng.Text) ' 用|分隔，避免空格冲突
                If Not QCFs.Exists(key) Then
                    QCFs.Add key, vbNull
                End If
            End If
            ' 移动到下一个匹配项，避免死循环
            rng.Collapse wdCollapseEnd
        Loop
    End With
    
    ' 执行批量替换
    Dim replaceCount As Integer
    replaceCount = 0
    For Each FontName In QCFs.Keys
        ' 拆分字体名和符号
        Dim parts() As String
        parts = Split(FontName, "|")
        FN = parts(0)
        Sym = parts(1)
        
        ' 获取替换内容
        If InStr(1, FN, "QCF_") > 0 Then
            If Font_.Exists(FN) And Font_(FN).Exists(Sym) Then
                ReplaceText = Font_(FN)(Sym)
            End If
        Else
            If Font2.Exists(FN) And Font2(FN).Exists(Sym) Then
                ReplaceText = Font2(FN)(Sym)
            End If
        End If
        
        ' 执行替换
        If ReplaceText <> "" Then
            With AD.Content.Find
                .ClearFormatting
                .Font.Name = FN
                .Text = Sym
                .Replacement.ClearFormatting
                .Replacement.Text = ReplaceText
                .Execute Replace:=wdReplaceAll
            End With
            replaceCount = replaceCount + 1
        End If
    Next FontName
    
    ' 恢复Word设置
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveDocument.CheckSpellingAsYouType = True
    ActiveDocument.CheckGrammarAsYouType = True
    
    ' 统计耗时
    SecondsElapsed = Round(Timer - StartTime, 2) / 60
    MsgBox "耗时(分钟): " & vbTab & SecondsElapsed & vbCr & "完成替换数: " & vbTab & replaceCount, vbOKOnly + vbInformation
End Sub

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