Load and parse json file to find and replace the symbols in active document

Question

I have two JSON files, both have symbols and its replacements:

1. QCF_.json
2. QCF2.json

You can find the JSON and Test files here.

I need to find the specific symbol in the whole document and replace with its equivalent from either of json files. I am using precise replacement procedure, consist of two steps.

1. to loop through each word of Active Document and gather the relevant font name and symbol.
2. Find/Replace the symbols with font name.

The procedure is as follows:

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
            
            'W.Select
            
            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
                
                'On Error Resume Next
                    For Each C In W.Words
                        'If QCFs.Exists(myF & " " & Trim(C.Text)) = False Then
                            'C.Select
                            C.Font.Name = myF
                            QCFs(myF & " " & Trim(C.Text)) = x
                        'End If
                    Next
                'On Error GoTo 0
            Else
                
                'W.Select
                x = x + 1
                'QCFs.Add W.Font.Name & " " & Trim(W.Text), x
                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

To load Json to Dictionary, I am opening in word document, then parsing using VBA-Parser. The function that loads JSON is as follows:

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
    
    '   Open JSON *********************************
        Application.StatusBar = "   Processing JSON ...   " & j
        Set oDoc = Documents.Open(ActiveDocument.Path & Application.PathSeparator & j, Visible:=False)
        With oDoc
            JsonText = .Range.Text
            .Close
        End With
        
        
    '   Parse JSON *********************************
        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

Problem with the above function is that it takes a lot of time to open and load JSON.

In Fact I used the following code to load JSON, it is fast in loading but replacing symbol is not matching.

Dim FSO As New FileSystemObject
Dim JsonTS As TextStream

Set JsonTS = FSO.OpenTextFile(ActiveDocument.Path & 
Application.PathSeparator & j, ForReading)
    JsonText = JsonTS.ReadAll
    JsonTS.Close

How can I optimize the complete process?

1. Opening JSON to read
2. find and replace symbols