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宏有五条规则：

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

其中，您只实施了＃3。此外，您通过重新保存工作表来加剧工作，这样您就可以执行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

请注意，因为我无法为您测试这个，并且因为原始代码中的Autofilter / Range效果存在很多隐含性，我无法判断它是否正确。你必须这样做。

注意：如果您决定实施此操作，请告诉我们它有什么影响，如果有的话。（我试着跟踪哪些有效，多少）

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

1 个答案: