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

Question

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

vbaexcel

7

我目前正在尝试制作一个宏，将前往一个目录，打开一个工作簿（当前有38个，最终总数是52个），过滤两个列，获取总计（这将重复4次），然后关闭工作簿。当前，我的应用程序处理当前的38个工作簿需要约7分钟。

如何加快速度？我已经禁用了屏幕更新、事件，并将计算方法更改为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

- user2843579

手动打开文件需要的时间不到一半。 - user2843579

1

看起来你正在为每个打开的Excel文件创建一个新副本。如果不这样做，可能会更快。 - RBarryYoung

我必须取消共享每个工作簿，以便按工作簿中的颜色代码进行排序，因此我必须将另一个文件保存为独占文件。 - user2843579

2

打开文件并另存为需要的时间大约是仅仅打开的两倍，这是有道理的。 - Alex Godofsky

我想，如果你从逻辑上认为两个动作需要的时间比一个动作长，那么这是一个好的结论。然而，当你比较每个动作执行所需的时间时，情况并非如此。saveAs() 的实现时间小于 2 秒。 - user2843579

显示剩余4条评论

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- RBarryYoung · Accepted Answer

通常制作Excel-VBA宏的五个规则如下：

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

你只实施了其中的第三个。此外，你通过重新保存工作表加剧了问题，只是为了执行Visual修改方法（在你的情况下是AutoFilter）。让它变快的方法是，首先实施其余规则，其次，停止修改源工作表以便以只读方式打开。

导致问题并迫使所有这些其他不良决策的核心是你实现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

请注意，因为我无法为您测试此代码，并且由于原始代码中的自动筛选/范围效果有很多隐含性，所以我无法确定它是否正确。您需要自行验证。

注意：如果您决定实施此代码，请告诉我们它产生了什么影响，如果有的话。（我尝试跟踪什么有效以及有效程度）