如何更快地打开此 VBA 工作簿？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19164840/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How can I open this VBA workbook faster?
提问by user2843579
I am currently trying to make a macro that will go to a directory, open a workbook (there are 38 currently with an eventual total of 52), filter two columns, get the total (repeat this 4 times), and the close the workbook. Currently it takes my application about 7 minutes just to process the current 38 workbooks.
我目前正在尝试制作一个将转到目录的宏，打开一个工作簿（目前有 38 个，最终总共 52 个），过滤两列，获得总数（重复 4 次），然后关闭工作簿. 目前，我的应用程序仅处理当前的 38 个工作簿就需要大约 7 分钟的时间。
How can I speed this up? I have already disables screen updating, events, and I changed the calculation methods to xlCalculationManual. I don't know if it common practice but I have seen people asking about a way to access a workbook without it being open but the suggestion to turn off screen updating is always made, which I have done.
我怎样才能加快速度？我已经禁用了屏幕更新、事件，并将计算方法更改为 xlCalculationManual。我不知道这是否是常见的做法，但我看到人们询问如何在不打开工作簿的情况下访问工作簿，但总是建议关闭屏幕更新，我已经这样做了。
When I run it in debug mode the Workbooks.Open() can take up to 10 seconds. The file directory is actually on a company network but accessing the file normally barely takes any time, under 5 seconds.
当我在调试模式下运行它时，Workbooks.Open() 最多可能需要 10 秒。文件目录实际上位于公司网络上，但访问文件通常几乎不需要任何时间，不到 5 秒。
The data in the workbooks can contain the same points but at a different status. I do not think combining all of the data into one workbook would be possible.
工作簿中的数据可以包含相同的点但处于不同的状态。我认为不可能将所有数据合并到一个工作簿中。
I am going to experiment with direct cell references. Once I have some results I will update my post.
我将尝试使用直接单元格引用。一旦我有一些结果，我会更新我的帖子。
Private UNAME As String
Sub FileOpenTest()
Call UserName
Dim folderPath As String
Dim filename As String
Dim tempFile As String
Dim wb As Workbook
Dim num As Integer
Dim values(207) As Variant
Dim arryindex
Dim numStr As String
Dim v As Variant
Dim init As Integer
init = 0
num = 1
arryindex = 0
numStr = "0" & CStr(num)
'Initialize values(x) to -1
For Each v In values
values(init) = -1
init = init + 1
Next
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
End With
'File path to save temp file
tempFile = "C:\Users\" & UNAME & "\Documents\TEMP.xlsm"
'Directory of weekly reports
folderPath = "path here"
'First file to open
filename = Dir(folderPath & "file here" & numStr & ".xlsm")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename)
'Overwrite previous "TEMP.xlsm" workbook without alert
Application.DisplayAlerts = False
'Save a temporary file with unshared attribute
wb.SaveAs filename:=tempFile, AccessMode:=xlExclusive
'operate on file
Filters values, arryindex
wb.Close False
'Reset file name
filename = Dir
'I use this loop to add the appropriate number to the end ie 01, 02, 03 etc
If num >= 9 Then
num = num + 1
If num = 33 Then
num = num + 1
End If
numStr = CStr(num)
ElseIf num < 9 Then
num = num + 1
numStr = "0" & CStr(num)
End If
filename = Dir(folderPath & "filename here" & numStr & ".xlsm")
Loop
output values
'Delete "TEMP.xlsm" file
On Error Resume Next
Kill tempFile
On Error GoTo 0
End Sub
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'filter column1
ActiveSheet.Range("B6").End(xlDown).AutoFilter Field:=2, Criteria1:=Array( _
"p1", "p2", "p3", "p4", "p5"), Operator:=xlFilterValues
'filter column2
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "d2", "s3"), Operator:=xlFilterValues
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter column2 for different criteria
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:="s"
'filter colum3 for associated form
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="<>"
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter coum 3 for blank forms
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="="
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter for column4 if deadline was made
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=52
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "s2", "s3", "s4", "s5", "s6"), Operator:=xlFilterValues
ActiveSheet.Range("BC6").End(xlDown).AutoFilter Field:=55, Criteria1:=RGB(146 _
, 208, 80), Operator:=xlFilterCellColor
'get total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
End Function
Public Function TotalCount() As Integer
Dim rTable As Range, r As Range, Kount As Long
Set rTable = ActiveSheet.AutoFilter.Range
TotalCount = -1
For Each r In Intersect(Range("A:A"), rTable)
If r.EntireRow.Hidden = False Then
TotalCount = TotalCount + 1
End If
Next
End Function
Function UserName() As String
UNAME = Environ("USERNAME")
End Function
Function output(ByRef values() As Variant)
Dim index1 As Integer
Dim index2 As Integer
Dim t As Range
Dim cw As Integer
'Calendar week declariations
Dim cwstart As Integer
Dim cstart As Integer
Dim cstop As Integer
Dim data As Integer
data = 0
start = 0
cw = 37
cstart = 0
cstop = 3
ThisWorkbook.Sheets("Sheet1").Range("B6").Activate
For index1 = start To cw
For index2 = cstart To cstop
Set t = ActiveCell.Offset(rowOffset:=index1, columnOffset:=index2)
t.value = values(data)
data = data + 1
Next
Next
End Function
回答by RBarryYoung
In general there are five rules to making Excel-VBA macros fast:
一般来说，有五个规则可以快速创建 Excel-VBA 宏：
Don't use
.Selectmethods,Don't use
Active*objects more than once,Disable screen-updating and automatic calculations,
Don't use visual Excel methods (like Search, Autofilter, etc),
And most of all, alwaysuse range-array copying instead of browsing individual cells in a range.
不要用
.Select方法，不要
Active*多次使用对象，禁用屏幕更新和自动计算，
不要使用可视化 Excel 方法（如搜索、自动筛选等），
最重要的是，始终使用范围数组复制，而不是浏览范围内的单个单元格。
Of these, you have only implemented #3. Additionally, you are exacerbating things by re-Saving your worksheets, just so that you can execute Visual modification methods (AutoFilter in your case). What you need to do to make it fast is to first implement the rest of these rules, and secondly, stop modifying your source worksheets so that you can open them read-only.
其中，您只实现了#3。此外，您通过重新保存工作表来加剧事情，只是为了您可以执行可视化修改方法（在您的情况下为 AutoFilter）。要使其快速完成，您需要做的是首先实现这些规则的其余部分，其次，停止修改源工作表，以便您可以以只读方式打开它们。
The core of what's causing your problems and forcing all of these other undesirable decisions is how you have implemented the Filtersfunction. Instead of trying to do everything with the visual Excel functions, which are slow compared to (well-written) VBA (and that modify the worksheets, forcing your redundant Saves), just range-array copy all of the data you need from the sheet and use straight-forward VBA code to do your counting.
导致您的问题并迫使所有这些其他不良决定的核心是您如何实现该Filters功能。与其尝试使用与（编写良好的）VBA 相比速度较慢的可视化 Excel 函数（以及修改工作表，强制进行冗余保存），不如尝试使用可视化 Excel 函数执行所有操作，只需从工作表中复制所需的所有数据范围数组即可并使用直接的 VBA 代码进行计数。
Here is an example of your Filtersfunction that I converted to these principles:
这是Filters我转换为这些原则的函数示例：
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error GoTo 0
Dim ws As Worksheet
Set ws = ActiveSheet
'find the last cell that we might care about
Dim LastCell As Range
Set LastCell = ws.Range("B6:AZ6").End(xlDown)
'capture all of the data at once with a range-array copy
Dim data() As Variant, colors() As Variant
data = ws.Range("A6", LastCell).Value
colors = ws.Range("BC6", "BC" & LastCell.Row).Interior.Color
' now scan through every row, skipping those that do not
'match the filter criteria
Dim r As Long, c As Long, v As Variant
Dim TotCnt1 As Long, TotCnt2 As Long, TotCnt3 As Long, TotCnt4 As Long
TotCnt1 = -1: TotCnt2 = -1: TotCnt3 = -1: TotCnt4 = -1
For r = 1 To UBound(data, 1)
'filter column1 (B6[2])
v = data(r, 2)
If v = "p1" Or v = "p2" Or v = "p3" Or v = "p4" Or v = "p5" Then
'filter column2 (J6[10])
v = data(r, 10)
If v = "s1" Or v = "d2" Or d = "s3" Then
'get the total of points
TotCnt1 = TotCnt1 + 1
End If
'filter column2 for different criteria
If data(r, 10) = "s" Then
'filter colum3 for associated form
If CStr(data(r, 52)) <> "" Then
'get the total of points
TotCnt2 = TotCnt2 + 1
Else
' filter coum 3 for blank forms
'get the total of points
TotCnt3 = TotCnt3 + 1
End If
End If
'filter for column4 if deadline was made
v = data(r, 10)
If v = "s1" Or v = "s2" Or v = "s3" Or v = "s4" Or v = "s5" Then
If colors(r, 1) = RGB(146, 208, 80) Then
TotCnt4 = TotCnt4 + 1
End If
End If
End If
Next r
values(arryindex) = TotCnt1
values(arryindex + 1) = TotCnt2
values(arryindex + 2) = TotCnt3
values(arryindex + 3) = TotCnt4
arryindex = arryindex + 4
End Function
Please note that because I cannot test this for you and also because there is a lot of implicitness to the Autofilter/Range effects in the original code, I cannot tell if it is correct. You will have to do that.
请注意，因为我无法为您测试这一点，并且因为原始代码中的自动过滤器/范围效果有很多隐含性，所以我无法判断它是否正确。你将不得不这样做。
Note: If you do decided to implement this, please let us know what impact it had, if any. (I try to keep track of what works and how much)
注意：如果您决定实施此功能，请告诉我们它有什么影响（如果有）。（我试图跟踪什么有效以及有多少）
