如何提高VBA WORD中循环的速度？

lingongzhe · 发表于 2021-2-9 14:37

本帖最后由 lingongzhe 于 2021-2-9 16:23 编辑

如图，我的VBA程序想做到检查RTF文档里是否有三线表跨页显示的情况。用循环table的方式检查具体是哪一页出现了跨页情况。但是当页数很大的时候，运行速度特别慢，例子class.rtf只是将近3000页，就已经要跑27分钟。如何能够提高效率和运行速度呢？
测试文档和我的VBA程序已经上传，求大神帮忙看下，万分感谢！

代码如下

Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)
Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)
Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)
Private Sub UserForm_Initialize()
Dim hWndForm As Long
Dim IStyle As Long
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
IStyle = GetWindowLong(hWndForm, GWL_STYLE)
IStyle = IStyle Or WS_THICKFRAME '还原
IStyle = IStyle Or WS_MINIMIZEBOX '最小化
IStyle = IStyle Or WS_MAXIMIZEBOX '最大化
SetWindowLong hWndForm, GWL_STYLE, IStyle
End Sub
Private Sub CommandButton1_Click()
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Dim t As Table, c As Cell
Dim f As Object
Dim MyTable As Table
Dim tabCount, pageCount, cellCount, firstCharPage, lastCharPage As Long
startTime = Date + Time
Selection.WholeStory
Selection.Delete unit:=wdCharacter, Count:=1
rtfPath = TextBox1.Value
FName = Dir(rtfPath & "" & "*.rtf")
n = 0
For Each f In CreateObject("scripting.FileSystemObject").GetFolder(rtfPath).Files
If f.Name Like "*.rtf" Then n = n + 1
Next
'插入表格
Set MyTable = ThisDocument.Tables.Add(Range:=ThisDocument.Range(Start:=0, End:=0), NumRows:=n + 1, NumColumns:=5)
With ThisDocument.Tables(1)
.Columns(1).Width = 125
.Columns(2).Width = 50
.Columns(3).Width = 50
.Columns(4).Width = 40
.Columns(5).Width = 150
.Borders.InsideLineStyle = wdLineStyleSingle
.Borders.OutsideLineStyle = wdLineStyleSingle
.Cell(Row:=1, Column:=1).Range.InsertAfter Text:="RTF"
.Cell(Row:=1, Column:=2).Range.InsertAfter Text:="表格数"
.Cell(Row:=1, Column:=3).Range.InsertAfter Text:="页码数"
.Cell(Row:=1, Column:=4).Range.InsertAfter Text:="标记"
.Cell(Row:=1, Column:=5).Range.InsertAfter Text:="跨页页码"
End With
'实例化word对象
On Error Resume Next
Set docApp = CreateObject("Word.Application")
i = 3
If Len(FName) > 0 Then
docApp.Documents.Open (rtfPath & "" & FName)
tabCount = docApp.ActiveDocument.Tables.Count
pageCount = docApp.Selection.Information(wdNumberOfPagesInDocument)
'检查跨页
If tabCount <> pageCount Then
For Each t In docApp.ActiveDocument.Tables
cellCount = t.Range.Cells.Count
firstCharPage = t.Range.Cells(1).Range.Characters.First.Information(wdActiveEndPageNumber)
lastCharPage = t.Range.Cells(cellCount).Range.Characters.First.Information(wdActiveEndPageNumber)
If firstCharPage <> lastCharPage Then
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=5).Range.InsertAfter Text:=firstCharPage & "; "
End With
End If
Next
End If
With ThisDocument.Tables(1)
.Cell(Row:=2, Column:=1).Range.InsertAfter Text:=FName
.Cell(Row:=2, Column:=2).Range.InsertAfter Text:=tabCount
.Cell(Row:=2, Column:=3).Range.InsertAfter Text:=pageCount
End With
If tabCount <> pageCount Then
With ThisDocument.Tables(1)
.Cell(Row:=2, Column:=4).Range.InsertAfter Text:="Y"
End With
With ThisDocument.Tables(1)
.Cell(Row:=2, Column:=1).Range.Font.ColorIndex = wdRed
.Cell(Row:=2, Column:=2).Range.Font.ColorIndex = wdRed
.Cell(Row:=2, Column:=3).Range.Font.ColorIndex = wdRed
.Cell(Row:=2, Column:=4).Range.Font.ColorIndex = wdRed
.Cell(Row:=2, Column:=5).Range.Font.ColorIndex = wdRed
End With
End If
pctDone = Format(1 / n, "0.0%")
With UserForm1
.Label2.Caption = 0
.Label2.Caption = pctDone
End With
docApp.ActiveDocument.Close False
Do
FName = Dir
If FName <> "" Then
docApp.Documents.Open (rtfPath & "" & FName)
tabCount = docApp.ActiveDocument.Tables.Count
pageCount = docApp.Selection.Information(wdNumberOfPagesInDocument)
'检查跨页
If tabCount <> pageCount Then
For Each t In docApp.ActiveDocument.Tables
cellCount = t.Range.Cells.Count
firstCharPage = t.Range.Cells(1).Range.Characters.First.Information(wdActiveEndPageNumber)
lastCharPage = t.Range.Cells(cellCount).Range.Characters.First.Information(wdActiveEndPageNumber)
If firstCharPage <> lastCharPage Then
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=5).Range.InsertAfter Text:=firstCharPage & "; "
End With
End If
Next
End If
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=1).Range.InsertAfter Text:=FName
.Cell(Row:=i, Column:=2).Range.InsertAfter Text:=tabCount
.Cell(Row:=i, Column:=3).Range.InsertAfter Text:=pageCount
End With
If tabCount <> pageCount Then
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=4).Range.InsertAfter Text:="Y"
End With
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=1).Range.Font.ColorIndex = wdRed
.Cell(Row:=i, Column:=2).Range.Font.ColorIndex = wdRed
.Cell(Row:=i, Column:=3).Range.Font.ColorIndex = wdRed
.Cell(Row:=i, Column:=4).Range.Font.ColorIndex = wdRed
.Cell(Row:=i, Column:=5).Range.Font.ColorIndex = wdRed
End With
End If
pctDone = Format(i / n, "0.0%")
With UserForm1
.Label2.Caption = 0
.Label2.Caption = pctDone
End With
i = i + 1
docApp.ActiveDocument.Close False
End If
Loop Until Len(FName) = 0
End If
With UserForm1
.Label2.Caption = 100
End With
Set docApp = Nothing
Application.DisplayAlerts = True
endTime = Date + Time
interval = Format(endTime - startTime, "hh:mm:ss")
MsgBox "耗时" & interval
MsgBox "Finished!", 64, " "
End Sub
Private Sub CommandButton2_Click()
Set objshell = CreateObject("wscript.shell")
Set DosExec = objshell.Exec("cmd.exe /c " & "taskkill /f /t /im WINWORD.exe")
Set DosExec = Nothing
Set objshell = Nothing
End Sub

复制代码

lingongzhe · 发表于 2021-2-9 16:31

主要就是针对下面的这段代码，求大佬帮忙解决下，万分感谢呢

'检查跨页
If tabCount <> pageCount Then
For Each t In docApp.ActiveDocument.Tables
cellCount = t.Range.Cells.Count
firstCharPage = t.Range.Cells(1).Range.Characters.First.Information(wdActiveEndPageNumber)
lastCharPage = t.Range.Cells(cellCount).Range.Characters.First.Information(wdActiveEndPageNumber)
If firstCharPage <> lastCharPage Then
With ThisDocument.Tables(1)
.Cell(Row:=i, Column:=5).Range.InsertAfter Text:=firstCharPage & "; "
End With
End If
Next
End If

复制代码

Jason_WangSS · 发表于 2021-2-10 09:01

你的class.rtf文件打开非常慢

lingongzhe · 发表于 2021-2-10 10:24

Jason_WangSS 发表于 2021-2-10 09:01
你的class.rtf文件打开非常慢

对，太大了，现实中我用到的还有是这个文件3-4倍大的文件。
不过我跑过，如果单纯检查class.rtf的页数，需要8分钟。但是要循环遍历每一个表格，就要28分钟了，说明这多出来的20分钟应该就是循环花的时间了。
现实项目里，可能会有5-6个很大的rtf文件，所以这么跑就会很没效率了。
大佬，不知道VBA可以直接从RTF的源码入手做到我这件事情吗，这样是不是就可以以txt的形式打开，速度会有质的飞跃了？

sylun · 发表于 2021-2-10 22:10

可试将Private Sub CommandButton1_Click过程改为如下代码，去掉Application.Visible = False行，用时会多些

Private Sub CommandButton1_Click()
Dim t As Table
Dim f As Object
Dim MyTable As Table
Dim StartTime As Date, EndTime As Date
Dim i%, n%, tabCount%, pageCount%, firstCharPage%
Dim rtfPath$, FName$, pctDone$, interval$
Dim data() As String
Dim info As String
Dim tabpageCount As Integer
Application.Visible = False '界面设为不可见
Application.ScreenUpdating = False
Application.DisplayAlerts = False
StartTime = Date + Time
rtfPath = TextBox1.Value
FName = Dir(rtfPath & "" & "*.rtf")
n = 0
For Each f In CreateObject("scripting.FileSystemObject").GetFolder(rtfPath).Files
If f.Name Like "*.rtf" Then n = n + 1
Next
Do While FName <> Empty
With Documents.Open(rtfPath & "" & FName)
ReDim Preserve data(i)
tabCount = .Tables.Count
pageCount = .Content.Information(wdNumberOfPagesInDocument)
If tabCount = 0 Then
data(i) = FName & vbTab & vbTab & pageCount
Else
For Each t In .Tables
firstCharPage = t.Range.Cells(1).Range.Characters.First.Information(wdActiveEndPageNumber)
If t.Range.ComputeStatistics(wdStatisticPages) > 1 Then info = info & firstCharPage & " ; "
Next
If info = Empty Then
data(i) = FName & vbTab & tabCount & vbTab & pageCount
Else
data(i) = FName & vbTab & tabCount & vbTab & pageCount & vbTab & "Y" & vbTab & info
End If
End If
info = Empty
.Close False
End With
i = i + 1
FName = Dir
Loop
With ThisDocument.Range(0, 0)
.Text = "RTF" & vbTab & "表格数" & vbTab & "页码数" & vbTab & "标记" & vbTab & "跨页页码" & vbCrLf & Join(data, vbCrLf)
.ConvertToTable
End With
With ThisDocument.Tables(1)
.Columns(1).Width = 125
.Columns(2).Width = 50
.Columns(3).Width = 50
.Columns(4).Width = 40
.Columns(5).Width = 150
.Borders.InsideLineStyle = wdLineStyleSingle
.Borders.OutsideLineStyle = wdLineStyleSingle
End With
With UserForm1
.Label2.Caption = 100
End With
Application.Visible = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
EndTime = Date + Time
interval = Format(EndTime - StartTime, "hh:mm:ss")
MsgBox "耗时" & interval
MsgBox "Finished!", 64, " "
End Sub

复制代码

lingongzhe · 发表于 2021-2-11 11:20

sylun 发表于 2021-2-10 22:10
可试将Private Sub CommandButton1_Click过程改为如下代码，去掉Application.Visible = False行，用时会多 ...

谢谢大佬，我读一读你的代码，试试哈，万分感谢

zpy2 · 发表于 2021-2-12 08:46

lingongzhe 发表于 2021-2-11 11:20
谢谢大佬，我读一读你的代码，试试哈，万分感谢

，太大了，现实中我用到的还有是这个文件3-4倍大的文件。

建议拆成小文件，或者html或者latex,markdown,就可以用字符串处理了。

lingongzhe · 发表于 2021-2-14 18:12

zpy2 发表于 2021-2-12 08:46
，太大了，现实中我用到的还有是这个文件3-4倍大的文件。

建议拆成小文件，或者html或者latex,markdow ...

好的好的，这些标记语言，我都不太会，那我得研究研究了，谢谢啦，非常感谢

		自动登录	找回密码
密码			免费注册

[求助] 如何提高VBA WORD中循环的速度？