vba - 如何更快地打开此 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

score 14 · Accepted Answer

一般来说，快速制作 Excel-VBA 宏有五个规则：

不要使用.Select方法，
不要Active*多次使用对象，
禁用屏幕更新和自动计算，
不要使用可视化 Excel 方法（如搜索、自动筛选等），
最重要的是，始终使用范围数组复制而不是浏览范围中的单个单元格。

其中，您只实现了#3。此外，您通过重新保存工作表来加剧事情，以便您可以执行视觉修改方法（在您的情况下为自动筛选）。您需要做的是首先实现这些规则的其余部分，其次，停止修改您的源工作表，以便您可以只读方式打开它们。

导致您的问题并迫使所有这些其他不良决定的核心是您如何实现该Filters功能。与其尝试使用与（编写良好的）VBA 相比速度较慢的可视 Excel 函数（并且会修改工作表，强制进行冗余保存），而是尝试使用范围数组从工作表中复制您需要的所有数据并使用直接的 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

请注意，因为我无法为您测试，而且原始代码中的 Autofilter/Range 效果有很多隐含性，我无法判断它是否正确。你将不得不这样做。

注意：如果您决定实施此操作，请让我们知道它有什么影响（如果有）。（我试图跟踪什么有效，多少有效）

vba - 如何更快地打开此 VBA 工作簿？

1 回答 1

Related

Reference