ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 347|回复: 7

[求助] 如何提高运行效率

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-9 17:53 | 显示全部楼层 |阅读模式
      我有一个很大的文档,要将其中的“会计分录”的格式进行统一化。我已经编制了一段宏代码,也运行成功,但运行的时间特别长(约半个小时)。这可能是因为我的代码的思路是逐段判断,由于段落较多,所以运行的时间较长。当文档很大、段落很多但需要替换的内容即并不多时,这个方法显然不科学,把很多时间浪费在遍历各个段落上了。现将文档及代码上传,请大神修改优化。
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







调整要求及调整前后的状态.png

文档.zip

11.71 KB, 下载次数: 6

TA的精华主题

TA的得分主题

发表于 2019-12-9 21:45 | 显示全部楼层
实际文档如果保密,脱敏后发上来,至少发包含各种情况的一部分。
虽然没看到实际文档,但有个思路就是查找替换,符合规则的行首加全角空格。

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-9 22:29 | 显示全部楼层
完整的代码还要进行其他的操作,上传时将其他的操作删除了,但开头的部分删除的不完整。

TA的精华主题

TA的得分主题

发表于 2019-12-10 08:31 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 09:49 | 显示全部楼层
谢谢ming0018,
第二段代码使用Range代替Selection,在运行 Do While .Execute  这一段代码时,将会死循环,需要找到一个方法跳出循环。
麻烦把相关的代码列出来

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 17:03 | 显示全部楼层
本帖最后由 GONG2816 于 2019-12-10 17:09 编辑

     在网上查找了一些资料,对第二种方法进行细化。其他的问题已经解决,现在的问题时如何退出“ 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

TA的精华主题

TA的得分主题

发表于 2019-12-10 17:20 | 显示全部楼层
GONG2816 发表于 2019-12-10 09:49
谢谢ming0018,
第二段代码使用Range代替Selection,在运行 Do While .Execute  这一段代码时,将会死循环 ...

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-11 14:13 | 显示全部楼层
终于找到原因了,将第下面第二行代码用第二行代码替换即可
.Wrap = wdFindContinue
     .Wrap = wdFindStop
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-2-22 22:24 , Processed in 0.388301 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表