如何更快地打开这个VBA工作簿？ [英] How can I open this VBA workbook faster?

问题描述

我目前正在尝试制作一个将要进入目录的宏，打开一个工作簿（目前共有38个，最终总数为52个），过滤两列，得到总数（重复这4次），关闭工作簿。目前，我的应用程序大约需要7分钟才能处理目前的38个工作簿。

我如何加速？我已经禁用屏幕更新，事件，我将计算方法更改为xlCalculationManual。我不知道是不是常见的做法，但我看到人们询问一种方法来访问一本工作簿而不打开它，但是我一直在做这个关于屏幕更新的建议。

当我在调试模式下运行它时，Workbooks.Open（）最多可能需要10秒钟。文件目录实际上在公司网络上，但通常访问文件几乎不需要5秒钟以下。

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

我将尝试直接的单元格引用。一旦我有一些结果，我会更新我的帖子。

 私人UNAME作为字符串
 
 Sub FileOpenTest ）
调用UserName 
 Dim folderPath As String 
 Dim filename As String 
 Dim tempFile As String 
 Dim wb As Workbook 
 Dim num As Integer 
 Dim值（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）
 
'初始化值（x）为-1 
对于每个v在值
值（init）= -1 
 init = init + 1 
下一个
 
使用Excel.Application 
 .ScreenUpdating = False 
 .Calculation = Excel.xlCalculationManual 
 .EnableEvents = False 
 .DisplayAlerts = False 
结束
 
'保存临时文件的文件路径
 tempFile =C：\Users\& UNAME& \Documents\TEMP.xlsm
'每周报告目录
 folderPath =path here
'要打开的第一个文件
 filename = Dir（folderPath& file here& numStr&.xlsm）
 Do While filename<> 
设置wb = Workbooks.Open（folderPath& filename）
'覆盖以前的TEMP.xlsm工作簿，无需
 Application.DisplayAlerts = False 
'保存临时带有非共享属性的文件
 wb.SaveAs filename：= tempFile，AccessMode：= xlExclusive 
 
'对文件操作
过滤器值arryindex 
 wb.Close False 
 
'重置文件名
文件名= Dir 
 
'我使用这个循环来添加适当的数字到01，02，03 etc 
如果num＃= 9然后
 num = num + 1 
如果num = 33 then 
 num = num + 1 
 End If 
 numStr = CStr（num）
 ElseIf num < 9然后
 num = num + 1 
 numStr =0& CStr（num）
 End If 
 
 filename = Dir（folderPath&filename here& numStr&.xlsm）
循环
 
输出值
 
'删除TEMP.xlsm文件
错误恢复下一步
杀死tempFile 
错误GoTo 0 
 End Sub 
 
函数过滤器（ByRef values（）As Variant，ByRef arryindex）
 On Error Resume Next 
 ActiveSheet.ShowAllData 
 On Error GoTo 0 
'filter column1 
 ActiveSheet.Range（B6）。End（xlDown）.AutoFilter字段：= 2，Criteria1：= Array（_ 
p1，p2，p3，p4 p5），运算符：= xlFilterValues 
'filter column2 
 ActiveSheet.Range（J6）。End（xlDown）.AutoFilter字段：= 10，Criteria1：= Array（_ 
 s1，d2，s3），运算符：= xlFilterValues 
'得到积分
值（arryindex）= TotalCount 
 arryindex = arryindex + 1 
 
'filter column2 for different criteria 
 ActiveSheet.Range（J6）。End（xlDown）.Aut oFilter字段：= 10，Criteria1：=s
'过滤器colum3用于关联表单
 ActiveSheet.Range（AZ6）。End（xlDown）.AutoFilter字段：= 52，Criteria1：= <>中
'得到积分
值（arryindex）= TotalCount 
 arryindex = arryindex + 1 
 
'过滤器空白3为空白表单
 ActiveSheet。范围（AZ6）。End（xlDown）.AutoFilter字段：= 52，Criteria1：==
'得到积分
值（arryindex）= TotalCount 
 arryindex = arryindex + 1 
 
'过滤器column4如果截止日期
 ActiveSheet.Range（J6）。End（xlDown）.AutoFilter字段：= 52 
 ActiveSheet.Range J6）。End（xlDown）.AutoFilter字段：= 10，Criteria1：= Array（_ 
s1，s2，s3，s4，s5，s6 ，运算符：= xlFilterValues 
 ActiveSheet.Range（BC6）。End（xlDown）.AutoFilter字段：= 55，Criteria1：= RGB（146 _ 
，208,80），运算符：= xlFilterCellColor 
'得到总分
值（arryindex）= TotalCount 
 arryindex = arryindex + 1 
 
结束函数
 
公共函数TotalCount ）As Integer 
 Dim rTable As Range，r As Ra nge，Kount As Long 
设置rTable = ActiveSheet.AutoFilter.Range 
 TotalCount = -1 
对于每个r In Inectect（Range（A：A），rTable）
如果r.EntireRow.Hidden = False然后
 TotalCount = TotalCount + 1 
结束If 
下一个
结束函数
 
函数UserName（）As String 
 UNAME = Environ（USERNAME）
结束函数
 
函数输出（ByRef values（）As Variant）
 Dim index1 As Integer 
 Dim index2 As整数
 Dim t As Range 
 Dim cw As Integer 
'日历周声明
 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）。激活
 
对于index1 = start到cw 
对于index2 = cstart到cstop 
设置t = ActiveCell。 Offset（rowOffset：= index1，columnOffset：= index2）
 t.value = values（data）
 data = data + 1 
 Ne xt 
下一个
 
结束函数
  

解决方案

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

1. 不要使用。选择方法




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




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




4. 不要使用可视化Excel方法（如搜索，自动过滤器等），




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

其中，您只实现了＃3。此外，您通过重新保存工作表来加剧事件，只需执行Visual修改方法（AutoFilter在您的案例中）。您需要做的是快速实现其余的规则，其次，停止修改源代码工作表，以便您可以只读它们。

引发问题的核心是强制所有这些其他不良的决定，是如何实现过滤器函数。而不是尝试使用可视化Excel函数（与精心编写的）VBA（并且修改工作表，强制您的冗余保存）相比较慢的可视化Excel函数，只需将范围数组从表中复制所需的所有数据并使用直接的VBA代码进行计数。

这是一个例子，您的过滤器函数，我转换为这些原则：

 函数过滤器（ByRef values（）As Variant，ByRef arryindex）
错误转到0 
 Dim ws As Worksheet 
设置ws = ActiveSheet 
 
'找到我们可能关心的最后一个单元
 Dim LastCell As Range 
 Set LastCell = ws .Range（B6：AZ6）。End（xlDown）
 
'用range-array复制一次捕获所有数据
 Dim data（）As Variant，colors（）作为Variant 
 data = ws.Range（A6，LastCell）.Value 
 colors = ws.Range（BC6，BC& LastCell.Row）.Interior.Color 
 
'现在sc通过每一行，跳过那些不
'匹配过滤条件
 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 
对于r = 1到UBound（数据，1）
 
'filter column1（B6 [2]）
v = data（r，2）
如果v =p1或v =p2或v =p3或v =p4或v =p5然后
 
'filter column2（J6 [10]）
v = data（r，10）
如果v =s1或v =d2或者d =s3然后
'得到积分
 TotCnt1 = TotCnt1 + 1 
 End If 
 
'不同条件的过滤器列2 
如果data（r，10）=s则
'filter colum3用于相关联的形式
如果CStr（data（r，52））& 然后
'得到积分
 TotCnt2 = TotCnt2 + 1 
 Else 
'过滤器空白3为空白表单
'得到积分
 TotCnt3 = TotCnt3 + 1 
如果
结束If 
 
'如果截止日期为$ 4，则为column4的过滤
v = data（r，10）
如果v =s1或v =s2或v =s3或v =s4或v =s5则
如果颜色（r，1）= RGB（146,208,80 ）然后
 TotCnt4 = TotCnt4 + 1 
结束如果
结束如果
 
结束如果
 
下一步r 
 
值（arryindex）= TotCnt1 
值（arryindex + 1）= TotCnt2 
值（arryindex + 2）= TotCnt3 
值（arryindex + 3）= TotCnt4 
 arryindex = arryindex + 4 
 
结束功能
  

请请注意，因为我无法为您进行测试，也因为原始代码中Autofilter / Range效果有很多隐含性，所以我无法确定是否正确。您必须这样做。

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

I am currently trying to make a macro that will go to a directory, open a workbook (there are 38 currently with an eventual total of 52), filter two columns, get the total (repeat this 4 times), and the close the workbook. Currently it takes my application about 7 minutes just to process the current 38 workbooks.

How can I speed this up? I have already disables screen updating, events, and I changed the calculation methods to xlCalculationManual. I don't know if it common practice but I have seen people asking about a way to access a workbook without it being open but the suggestion to turn off screen updating is always made, which I have done.

When I run it in debug mode the Workbooks.Open() can take up to 10 seconds. The file directory is actually on a company network but accessing the file normally barely takes any time, under 5 seconds.

The data in the workbooks can contain the same points but at a different status. I do not think combining all of the data into one workbook would be possible.

I am going to experiment with direct cell references. Once I have some results I will update my 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

解决方案

In general there are five rules to making Excel-VBA macros fast:

1. Don't use .Select methods,

2. Don't use Active* objects more than once,

3. Disable screen-updating and automatic calculations,

4. Don't use visual Excel methods (like Search, Autofilter, etc),

5. And most of all, always use range-array copying instead of browsing individual cells in a range.

Of these, you have only implemented #3. Additionally, you are exacerbating things by re-Saving your worksheets, just so that you can execute Visual modification methods (AutoFilter in your case). What you need to do to make it fast is to first implement the rest of these rules, and secondly, stop modifying your source worksheets so that you can open them read-only.

The core of what's causing your problems and forcing all of these other undesirable decisions is how you have implemented the Filters function. Instead of trying to do everything with the visual Excel functions, which are slow compared to (well-written) VBA (and that modify the worksheets, forcing your redundant Saves), just range-array copy all of the data you need from the sheet and use straight-forward VBA code to do your counting.

Here is an example of your Filters function that I converted to these principles:

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

Please note that because I cannot test this for you and also because there is a lot of implicitness to the Autofilter/Range effects in the original code, I cannot tell if it is correct. You will have to do that.

Note: If you do decided to implement this, please let us know what impact it had, if any. (I try to keep track of what works and how much)

这篇关于如何更快地打开这个VBA工作簿？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！