如何更快地打开这个VBA工作簿？

我目前正在尝试制作一个macros，它将进入一个目录，打开一个工作簿（目前有38个，最终总数为52），过滤两列，获得总数（重复这4次），并closures工作簿。 目前，我的应用程序需要大约7分钟来处理当前的38个工作簿。

我怎样才能加快速度呢？ 我已经禁用屏幕更新，事件，我改变了计算方法xlCalculationManual。 我不知道这是否是通用的做法，但我曾经看到有人问过在不打开的情况下访问工作簿的方法，但总是提出closures屏幕更新的build议。

当我在debugging模式下运行时，Workbooks.Open（）最多可能需要10秒。 文件目录实际上是在公司networking上，但是通常只需要5秒就可以访问文件。

工作簿中的数据可以包含相同的点，但处于不同的状态。 我不认为把所有的数据合并成一个工作簿是可能的。

我将试验直接单元格引用。 一旦我有一些结果，我会更新我的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 

Answer 1

总的来说，有五条规则可以快速制作Excel-VBAmacros：

1. 不要使用。select方法，

2. 不要多次使用Active*对象，

3. 禁用屏幕更新和自动计算，

4. 不要使用可视化的Excel方法（如Search，Autofilter等），

5. 最重要的是， 总是使用范围数组复制而不是浏览范围内的单个单元格。

其中，你只实现了＃3。 此外，通过重新保存工作表，您正在恶化事情，以便您可以执行可视化修改方法（在您的情况下使用AutoFilter）。 你需要做的是快速实现这些规则的其余部分，其次，停止修改你的源工作表，以便你可以以只读方式打开它们。

造成你的问题和迫使所有这些其他不合需要的决定的核心是你如何实现Filtersfunction。 而不是试图用可视化的Excelfunction来处理所有的事情，这些function比（写得很好的）VBA（以及修改工作表，强制多余的保存）要慢，只需要从表格中复制所需的所有数据并使用直接的VBA代码来做你的计数。

以下是我转换为以下原则的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 

请注意，因为我无法为您testing，也因为原始代码中的自动过滤/范围效应有很多隐含的含义，所以我不能确定它是否正确。 你将必须这样做。

注意：如果您决定实施这个，请让我们知道它有什么影响，如果有的话。 （我试图跟踪什么可行，多less）