新人初学，word宏 修改字体用，一次大概10w个字左右，运行最快都要10分钟，最慢就直接卡死，请大佬不吝赐教

[qq_37179700]

Sub 随机模仿手写()

Dim Ra As Range
Dim FontSize() As String
FontSize = Split("16.5,16.5,17,18", ",")
Dim FontName() As String
FontName = Split("A1,A2,A3,A4,A5", ",")
a = 0
'a值调整字体上下的偏差
b = 1
'b值调整字间距
'c = 20
'c值调整行间距
For Each Ra In ActiveDocument.Characters
VBA.Randomize
FontNameLength = UBound(FontName) - LBound(FontName)
FontSizeLength = UBound(FontSize) - LBound(FontSize)
Ra.Font.Name = FontName(Int(VBA.Rnd * FontNameLength) + 1)
Ra.Font.Size = FontSize(Int(VBA.Rnd * FontSizeLength) + 1)
Ra.Font.Position = Choose(Int(VBA.Rnd * 0.5) + 1, -1, -0.5, 0, 0.5, 1) + a
Ra.Font.Spacing = Choose(Int(VBA.Rnd * 1) + 1, -1.5, -1, -0.5, 0, 0.5, 1, 2) + b
If Ra = "。" Or Ra = "，" Or Ra = "；" Or Ra = "’" Or Ra = "‘" Or Ra = "“" Or Ra = "”" Or Ra = "！" Or Ra = "：" Then
'Ra.Font.Name = "A1"
Ra.Font.Size = "14"
Ra.Font.Position = "-0.5"
Ra.Font.Spacing = "-1"
'ElseIf Asc(Ra) >= 48 And Asc(Ra) <= 57 Then
' Ra.Font.Name = "J2,J3,J4"
ElseIf Asc(Ra) >= 97 And Asc(Ra) <= 122 Or Asc(Ra) >= 65 And Asc(Ra) <= 90 Or Ra = " . " Or Ra = "（" Or Ra = "）" Or Ra = "(" Or Ra = ")" Or Ra = "～" Then
'Ra.Font.Name = "J1,J2,J3,J4,J5,A1,A2,A3"
End If
If Ra = "." Or Ra = "状" Then
Ra.Font.Name = "A3"
Ra.Font.Size = "16.5"
Ra.Font.Position = "0"
Ra.Font.Spacing = "0"
End If
If Ra = "，" Or Ra = "、" Then
Ra.Font.Name = "A3"
Ra.Font.Size = "16.5"
Ra.Font.Position = "0"
Ra.Font.Spacing = "-5"
End If
If Ra = "0" Or Ra = "、" Then
Ra.Font.Size = "11"
Ra.Font.Position = "0"
Ra.Font.Spacing = "0"
End If
If Ra = "顶" Then
Ra.Font.Name = "W3"
Ra.Font.Size = "16.5"
Ra.Font.Position = "0"
Ra.Font.Spacing = "0"
End If
Next

'For Each Ra In ActiveDocument.Paragraphs

' Ra.ParagraphStyle.LineSpacingRule = wdLineSpaceExactly
' Ra.ParagraphStyle.LineSpacing = Int(VBA.Rnd * 1) + 1 + c
' Next


'With Selection.ParagraphFormat
' .FirstLineIndent = CentimetersToPoints(0.35)
' .CharacterUnitFirstLineIndent = 0
' End With

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "“"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute2007 Replace:=ReplaceAll
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 = False
End Sub

[赵4老师]

加Debug.Print语句，可在立即窗口显示中间变量值。

[不懂别说哎]

如果算法不能优化的时候，只能在效率上优化了，你可以将多个IF的判断改成case这样可以节省一部分开销，另外在频繁使用一个对象的各种属性或方法的时候可以用WITH 来减少调用对象的次数

[X-i-n]

每个字都遍历一次，不卡才稀奇，无解。

[脆皮大雪糕]

太长，随便看一眼，一个字一个字的调格式，咋想的。 下面又有针对某些特殊字符的处理。 你要知道十万个字里面需要特殊处理的字能占1%么？为了这1%把所有撸一遍卡死你！！ 正常的，如果你不会VBA，手工操作咋操作？先全选，把全篇先设定好字号行间距，然后再去把特殊字符一个一个改对吧。程序一样，先全改格式，然后搜索固定字符，这个搜索虽然也是全撸，但是由于绝大部分字符仅仅做了一次字符串比较而没有做其他任何操作，效率会高很多。至于界面卡死问题，在循环体内加一句 doevents能改善