如何提高运行效率

GONG2816

      我有一个很大的文档，要将其中的“会计分录”的格式进行统一化。我已经编制了一段宏代码，也运行成功，但运行的时间特别长（约半个小时）。这可能是因为我的代码的思路是逐段判断，由于段落较多，所以运行的时间较长。当文档很大、段落很多但需要替换的内容即并不多时，这个方法显然不科学，把很多时间浪费在遍历各个段落上了。现将文档及代码上传，请大神修改优化。

Sub 会计分录格式整理()   ’****此代码已经测试通过

Dim FL%: FL = 0       '分录状态，0：处于非分录，1：“借：”之后“贷：”之前标志，2：“贷：”之后直到分录结束的标志

h =Time

   

Application.DisplayAlerts = False  '关闭提示

On Error Resume Next  '忽略错误

Set Reg =CreateObject("vbscript.regexp")

Reg.Global = True: Reg.ignorecase = False:Reg.MultiLine = True

'MsgBox "开始遍历段落，将章节●▲记入数组"

h1 = Time

For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环

   DD = DD + 1

   Debug.Print "【标题】正在处理段落：" & DD

   DoEvents '防假死

   ActiveDocument.Paragraphs(DD).Range.Select  '只有先有这个选择，后面才能判断是否处于表格中

   If Selection.Information(wdWithInTable) = False Then   '如果不是处于表格中【1】

       Reg.Pattern = "^借："

       If Reg.test(i.Range.Text) = True Then

                      i.CharacterUnitFirstLineIndent = 2 '行首空2格

            i.Range.Font.Color = 5287936

           FL = 1

       Else

           Reg.Pattern = "^贷："

           If Reg.test(i.Range.Text) = True Then

                        FL = 2

                       i.CharacterUnitFirstLineIndent = 4 '行首空4格

               ElseIf FL = 1 Then

                      i.CharacterUnitFirstLineIndent = 4 '行首空4格

                ElseIf FL = 2 Then

                      i.CharacterUnitFirstLineIndent = 6 '行首空6格

           End If

       End If

       If FL <> 0 Then i.Range.Font.Color = 5287936  '分录的字体设置为墨绿色                  

       Reg.Pattern = "♂$"          '设定♂为分录的结尾标识

       If Reg.test(i.Range.Text) = True Then FL = 0

   End If

Next   

   MsgBox (Time - h) * 24 * 60 * 60

End Sub

     我换了一个思路，先找到文档中的“借：”，然后再对这一个分录进行格式整理，我觉得这个思路可能会提高运行效率，但我目前的知识无法完成这项工作。这部分没有完成的代码我也上传，看大神们觉得此思路是否行得通。

Sub A123()   ’********有部分代码没有完成

Selection.WholeStory   '选择全部文档

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

   .Text = "♀借：*^13"

   .Replacement.Text = "^&"

   .Forward = True

   .Wrap = wdFindContinue

   .Format = True

    .MatchCase = False

   .MatchWholeWord = False

   .MatchByte = False

   .MatchAllWordForms = False

   .MatchSoundsLike = False

   .MatchWildcards = True

   With .Replacement

       .ClearFormatting

       .Font.Bold = False

   End With

    .Execute Replace:=wdReplaceAll

   Do While .Execute    '只能通过循环的方式修改段落格式

       .Parent.ParagraphFormat.CharacterUnitFirstLineIndent = 4  '对于段落格式，需要用此方式才能设置成功，如果像字体".Replacement.font"那样设置是无效的

   '************我希望在这个循环里，对每一组分录的格式进行调整

   ’*************这一块是不我懂的地方。请大神指导

   Loop

End With

End Sub

kingtau

实际文档如果保密，脱敏后发上来，至少发包含各种情况的一部分。
虽然没看到实际文档，但有个思路就是查找替换，符合规则的行首加全角空格。

第一段代码和正则没有关系，怎么还用上正则了？

GONG2816

完整的代码还要进行其他的操作，上传时将其他的操作删除了，但开头的部分删除的不完整。

ming0018

使用Range代替Selection

GONG2816

谢谢ming0018，
第二段代码使用Range代替Selection，在运行 Do While .Execute  这一段代码时，将会死循环，需要找到一个方法跳出循环。
麻烦把相关的代码列出来

GONG2816

     在网上查找了一些资料，对第二种方法进行细化。其他的问题已经解决，现在的问题时如何退出“ Do While .Execute”循环。在网上搜索了一些资料，用如下三个方法判断光标的位置退出，实际也不起使用。
    请救高手指导。



Sub A123()

Dim myRange As Range, Ra As Range, myTable As Table
Set myRange = ActiveDocument.Range
With myRange.Find
    .Text = "♀借：*^13"
    .Replacement.Text = "^&"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    With .Replacement
        .ClearFormatting
        .Font.Bold = False
        .Font.Color = 5287936  '分录的字体设置为墨绿色
    End With
   
    Do While .Execute
        .Execute Replace:=wdReplaceOne     '替换 遇到的第一个匹配项。
        .Parent.ParagraphFormat.CharacterUnitFirstLineIndent = 2  
        bh = ActiveDocument.Range(Start:=0, End:=.Parent.End).Paragraphs.Count    '计算找到的项目在整个文档中的段落编号
        FL = 1
      
        Do While FL > 0
            bh = bh + 1
            If bh > ActiveDocument.Paragraphs.Count Then FL = 0        '当bh超过了总文档段落数时，要退出循环
            ActiveDocument.Paragraphs(bh).Range.Select
            Select Case FL
                Case 1: kg = 4  'kg变量用于表示行首空格数
                Case 2: kg = 6
            End Select
        
            With Selection
                .ParagraphFormat.CharacterUnitFirstLineIndent = kg
                .Font.Bold = False
                .Font.Color = 5287936  '分录的字体设置为墨绿色
            End With
            
            
               
            If InStr(ActiveDocument.Paragraphs(bh).Range, "♀贷：") = 1 Then FL = 2    '当“贷：”处于段首时，标识FL
            If InStr(ActiveDocument.Paragraphs(bh).Range, "♂") > 0 Then FL = 0   '将FL置0，本分录的处理结束
        Loop
       If Selection.Start = ActiveDocument.Content.End - 1 Then GoTo AAA   '在网上搜索的方法，实际运行不起作用
        If Selection.Range.Characters(1) = Chr(13) Then GoTo AAA   '在网上搜索的方法，实际运行不起作用
        If Selection.EndKey(unit:=wdStory, Extend:=wdMove) = 0 Then GoTo AAA   '在网上搜索的方法，实际运行不起作用
       '现在的问题是：在处理完后，它不能自动跳出循环，上面的三行代码分别运行也不能退出循环，请大神指导
            
            End If
     Loop
End With
AAA:
'以下删除"♀"符号
Set objFind = ActiveDocument.Content.Find
objFind.Execute Wrap:=wdFindContinue, MatchWildcards:=False, FindText:="♀", replacewith:="", Replace:=wdReplaceAll

End Sub

ming0018

GONG2816 发表于 2019-12-10 09:49
谢谢ming0018，
第二段代码使用Range代替Selection，在运行 Do While .Execute  这一段代码时，将会死循环 ...

自己先找下原因，才能真正了解 .execute的原理。
明天还没搞清楚的话　我再来解答。

GONG2816

终于找到原因了，将第下面第二行代码用第二行代码替换即可
.Wrap = wdFindContinue
     .Wrap = wdFindStop