如何更快地打開此VBA工作簿？

Question

我目前正在嘗試製作一個宏，它將進入一個目錄，打開一個工作簿（目前有38個，最終總數爲52），過濾兩列，獲得總數（重複這4次），並關閉工作手冊。目前，我的應用程序需要大約7分鐘才能處理當前的38個工作簿。

如何加快速度？我已經禁用了屏幕更新，事件，我將計算方法更改爲xlCalculationManual。我不知道這是否是普遍的做法，但我曾看到有人詢問如何在不打開工作簿的情況下訪問工作簿，但始終會提出關閉屏幕更新的建議，這是我所做的。

當我在調試模式下運行它時，Workbooks.Open（）最多可能需要10秒。文件目錄實際上位於公司網絡上，但通常只需5秒即可訪問該文件。

工作簿中的數據可以包含相同的點但處於不同的狀態。我不認爲將所有數據合併到一個工作簿中是可能的。

我將試驗直接單元格引用。一旦我有一些結果，我會更新我的文章。

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的VBA宏快：

1. 不要使用.Select方法，

2. 不要使用Active*對象不止一次，

3. 禁用屏幕更新和自動計算，

4. 不要使用Excel的可視化方法（如搜索，自動篩選等），

5. 最重要的是，總是使用範圍陣列的複製，而不是在一個範圍內瀏覽單個細胞。

其中，你只實現了＃3。此外，通過重新保存工作表，您正在惡化事情，以便您可以執行可視化修改方法（在您的情況下使用AutoFilter）。你需要做的是快速實現其餘的規則，其次，停止修改你的源工作表，以便你可以以只讀方式打開它們。

造成你的問題和強迫所有這些其他不良決定的核心是你如何實現Filters函數。而不是試圖用可視化的Excel函數來處理所有事情，這些函數與（精心編寫的）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 

請注意，因爲我無法測試這個給你，也因爲有很多隱性的自動篩選/範圍在原始代碼中的效果，我不知道它是否正確。你必須這樣做。

注意：如果您決定實施此操作，請告訴我們它有什麼影響（如果有）。 （我試圖跟蹤什麼是有效的和多少）