小白一枚 问一下 大神看懂的教教我怎么做

求高手挑战－word如何排版出手写效果？？
为了以假乱真，我又增加了一种字体，双引号干脆不要了。但是有个问题就是效率太低了，页数多了像死机了。
Sub 手写字体()
    Dim R_Character As Range
    Application.ScreenUpdating = False
    For Each R_Character In ActiveDocument.Characters
        VBA.Randomize
        If R_Character <> "。" Or R_Character <> "’" Or R_Character <> "‘" Or R_Character <> "“" Or R_Character <> "”" Or R_Character <> "！" Or R_Character <> "？" Or R_Character <> "、" Then
         R_Character.Font.Name = Choose(Int(VBA.Rnd * 2) + 1, "方正静蕾简体", "书体坊安景臣钢笔行书")
         Else
         R_Character.Font.Name = "方正静蕾简体"
         End If
        R_Character.Font.Size = Choose(Int(VBA.Rnd * 7) + 1, "18", "17.5", "17", "19.5", "18.5", "19", "20")
        R_Character.Font.Position = Choose(Int(VBA.Rnd * 5) + 1, 1.5, 2.5, 2, 0, 1)
        R_Character.Font.Spacing = Choose(Int(VBA.Rnd * 5) + 1, -1.8, -1.5, -1.6, -1.7, -1.4)
    Next
Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "“"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "”"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Application.ScreenUpdating = True
End Sub
这段程序如何实现
大神教教我 必有重谢 原帖在这里http://club.