vba 加速 Excel 自动筛选

Speed up Excel Autofilter

提问by Talguy

I have a workbook that I made which generates a density map of I/O signals in an industrial plant. The whole workbook is driven by the lead sheet which the user inputs the signal type and where it is located. On the worksheet that generates the density map I give the user the ability to click a cell of interest in the density map. when the user clicks the cell a on_selectionChange macro will run computing the location in the plant. The location is than fed into the lead sheets auto filter to show the user what signals are actually at that spot in the plant. My problem is that the location information is computed instantly, but when I go to apply the filter criteria to the autofilter it takes 12 seconds for the filter to apply and the code to change from the density map sheet to the lead database sheet. So does anyone know how I can speed up my code with autofilters. I do turn off screen updating and application calculations when running the macro. This has never been this slow until I started adding other sheets to the workbook. Below you can see my code on how I compute the location. Can someone help me out with this

我制作了一本工作簿，可生成工业工厂中 I/O 信号的密度图。整个工作簿由用户输入信号类型和位置的铅板驱动。在生成密度图的工作表上，我让用户能够单击密度图中感兴趣的单元格。当用户单击单元格时，on_selectionChange 宏将运行计算工厂中的位置。然后将该位置送入铅板自动过滤器，以向用户显示工厂中该位置的实际信号。我的问题是位置信息是立即计算的，但是当我将过滤条件应用于自动过滤器时，过滤器应用需要 12 秒，代码从密度地图表更改为铅数据库表。那么有谁知道我如何使用自动过滤器加速我的代码。运行宏时，我确实关闭了屏幕更新和应用程序计算。在我开始向工作簿添加其他工作表之前，这从未如此缓慢。您可以在下面看到我关于如何计算位置的代码。有人可以帮我解决这个问题吗

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    ' Filter the I/O data to those associated with the clicked cell

    ' Turn off screen updating, this speeds up Calc
    Application.ScreenUpdating = False
    ' Turn off automatic calculations
    Application.Calculation = xlCalculationManual

    ' Setup benchmarking
    Dim Time1 As Date
    Time1 = Timer
    Dim Time2 As Date


    Dim rngOLD As Boolean
    Dim rngNEW As Boolean

    Const Building_rng = "C4:K6"
    Const Lvl_rng = "C4:E30"
    Const RL_rng = "C4:C6"
    Const FB_rng = "C4:E4"
    Dim NEW_Offset As Integer
    Dim Extra_Off As Integer
    Dim rowOff As Integer
    Dim colOff As Integer

    ' Define Filter Criteria Variables
    Dim Criteria_Building As String ' Building
    Dim Criteria_lvl As String      ' Building Level
    Dim Criteria_FB As String       ' Front/Back on Level
    Dim Criteria_RL As String       ' Left/Right on Level

    rngOLD = InRange(Target, Worksheets("Density Map").Range("C4:K27"))
    rngNEW = InRange(Target, Worksheets("Density Map").Range("N4:V30,W4:Y12"))

    If (rngOLD Or rngNEW) And Not RangeIsBlank(Target) Then
        If rngNEW Then
            NEW_Offset = 11

            Criteria_Building = FindBuildingionNEW(Target, Union(Range(Building_rng).Offset(0, NEW_Offset), Range("W4:Y6")))

            ' Account for the Extra module in NEW Building
            If Criteria_Building = "Extra" Or Criteria_Building = "5" Or Criteria_Building = "6" Or Criteria_Building = "7" _
               Or Criteria_Building = "8" Or Criteria_Building = "9" Or Criteria_Building = "10" Then
                Extra_Off = 3
            End If
        Else
            Criteria_Building = FindBuildingionOLD(Target, Range(Building_rng))
        End If

        Criteria_lvl = FindLvl(Target, Range(Lvl_rng).Offset(0, NEW_Offset), Criteria_Building)

        ' Get the offsets, Default will return zero if not found
        rowOff = getBuildingionOffset(Criteria_Building) + Extra_Off
        colOff = getLevelOffset(Criteria_lvl)

        Criteria_RL = FindRLFB(Target, Range(RL_rng).Offset(0, NEW_Offset), 1, rowOff, colOff)
        Criteria_FB = FindRLFB(Target, Range(FB_rng).Offset(0, NEW_Offset), 2, rowOff, colOff)

        ' Benchmark
        Debug.Print "1st Half Time: " & Format(Timer - Time1, "00:00")
        Time2 = Timer
        ' End Benchmark

        ' Filter sheet based on click position
        If rngVA Then ' Filter OLD location data
            With Worksheets("IO Data")
                .AutoFilterMode = False
                With .Range("A3:Z3")
                    .AutoFilter
                    .AutoFilter Field:=10, Criteria1:=Criteria_Building
                    .AutoFilter Field:=12, Criteria1:=Criteria_lvl, Operator:=xlOr, Criteria2:=""
                    .AutoFilter Field:=13, Criteria1:=Criteria_FB, Operator:=xlOr, Criteria2:=""
                    .AutoFilter Field:=14, Criteria1:=Criteria_RL, Operator:=xlOr, Criteria2:=""
                End With
            End With
        Else ' Filter NEW location data
            With Worksheets("IO Data")
                .AutoFilterMode = False
                With .Range("A3:Z3")
                    .AutoFilter
                    .AutoFilter Field:=17, Criteria1:=Criteria_Building
                    .AutoFilter Field:=19, Criteria1:=Criteria_lvl, Operator:=xlOr, Criteria2:=""
                    .AutoFilter Field:=20, Criteria1:=Criteria_FB, Operator:=xlOr, Criteria2:=""
                    .AutoFilter Field:=21, Criteria1:=Criteria_RL, Operator:=xlOr, Criteria2:=""
                End With
            End With
        End If

        ' Turn on automatic calculations
        Application.Calculation = xlCalculationAutomatic
        ' Turn on screen updating
        Application.ScreenUpdating = True

        Worksheets("IO Data").Activate

        ' Benchmark
        Debug.Print "Autofilter Time: " & Format(Timer - Time2, "00:00")
        ' End Benchmark
    End If
End Sub

回答by chris neilsen

Inspired by barrowc 's answer, you could try this:

受到 barrowc 回答的启发，你可以试试这个：

Rather than autofiltering in place, add a report sheet using a 'Get External Data' reference (from the same workbook, in spite of the name!) that returns the required filterd result set.

不是就地自动过滤，而是使用返回所需过滤结果集的“获取外部数据”引用（来自同一个工作簿，尽管名称不同！）添加报告表。

To set up, add a connectionselect: From Data, Get External Data, Other Sources, Microsoft Query, Excel Files, and select your current workbook. (based on excel 2010, other excel version menus are a little different)

要进行设置，请添加一个连接选择：从数据、获取外部数据、其他源、Microsoft Query、Excel 文件，然后选择您当前的工作簿。（基于excel 2010，其他excel版本菜单略有不同）

Set up the query on your 'IO data' sheet, and include a WHERE clause (any criteria will do, you will edit this with code later)

在“IO 数据”表上设置查询，并包含 WHERE 子句（任何条件都可以，稍后您将使用代码对其进行编辑）

Update your _SelectionChangecode to modify the connections query

更新您的_SelectionChange代码以修改连接查询

Here's a sample of code to access the connection (this assumes only 1 connection in the workbook, which queries a set of sample data I created to test the performance):

这是访问连接的代码示例（这里假设工作簿中只有 1 个连接，它查询我创建的一组示例数据以测试性能）：

Sub testConnection()
    Dim wb As Workbook
    Dim c As WorkbookConnection
    Dim sql As String
    Dim Time2 As Date

    Time2 = Timer

    Set wb = ActiveWorkbook

    Set c = wb.Connections.Item(1)
    sql = c.ODBCConnection.CommandText
    sql = Replace(sql, "WHERE (`'IO Data$'`.k=10)", _ 
     "WHERE (`'IO Data$'`.k=9) AND (`'IO Data$'`.l=11) AND (`'IO Data$'`.m=12) AND (`'IO Data$'`.n=13)   ")
    c.ODBCConnection.CommandText = sql
    c.Refresh

    Debug.Print "Connection Time: " & Format(Timer - Time2, "00:00")

End Sub

I performed a simple test on a data set of 26 columns, 50,000 rows, all cells containing a simple formula referencing another cell.
Running on Win7 with Office2010, Autofilter took 21seconds to execute, and this method < 1 second

我对 26 列、50,000 行的数据集进行了简单测试，所有单元格都包含一个引用另一个单元格的简单公式。
在Win7和Office2010上运行，Autofilter执行耗时21秒，此方法<1秒

Adapting this to your requirements will be basically building the WHERE clause part of the sql query string, accessed in c.ODBCConnection.CommandText

使其适应您的要求将基本上构建 sql 查询字符串的 WHERE 子句部分，访问 c.ODBCConnection.CommandText

回答by barrowc

You might need to look at using ADO to filter the sheet. That should be substantially faster but there's a bit of a learning curve. Start with this overview.

您可能需要考虑使用 ADO 来过滤工作表。这应该快得多，但有一点学习曲线。从这个概述开始。

You'll need to add a reference to "Microsoft ActiveX Data Objects 2.8 Library" before you can use ADO

您需要先添加对“Microsoft ActiveX Data Objects 2.8 Library”的引用，然后才能使用 ADO