加速Excel自動過濾器

Question

我有一本工作手冊，它可以在工業工廠中生成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 

Answer 1

你可能需要看看使用ADO來過濾工作表。這應該是快得多，但有一點學習曲線。從this overview開始。

你需要添加一個引用到「Microsoft ActiveX數據對象2.8庫」，然後才能使用ADO

Answer 2

通過barrowc的回答啓發，你可以試試這個：

，而不是自動篩選使用「獲取外部數據」參考（來自同一工作簿，儘管名稱不變！）添加報告表，返回所需的篩選結果集。

要設置，添加connectionselect：從數據，獲取外部數據，其他源，Microsoft Query中，Excel文件，並選擇您的當前工​​作簿。 （基於excel 2010，其他excel版本菜單有點不同）

在'IO數據'表上設置查詢，幷包含WHERE子句（任何標準都會執行，稍後您將使用代碼進行編輯）

更新您的_SelectionChange代碼來修改連接查詢

這裏的代碼來訪問連接的樣品（假定只有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 

我對包含26列50000行的數據集執行了一個簡單測試，所有單元格都包含一個引用另一個單元格的簡單公式。
運行Win7上使用Office2010的，自動篩選了21秒來執行，而這種方法<1秒

適應這個您的要求將基本構建SQL查詢字符串的WHERE子句，在c.ODBCConnection.CommandText