Ускорьте автофильтр Excel

Question

У меня есть книга, которую я создал, которая генерирует карту плотности сигналов ввода / вывода на промышленном предприятии.Вся рабочая тетради приводится ведомостью, в которой пользователь вводит тип сигнала и место его расположения.На рабочем листе, который генерирует карту плотности, я даю пользователю возможность щелкнуть интересующую ячейку на карте плотности.когда пользователь щелкает ячейку, запускается макрос 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

Вдохновленный ответом Барроука, вы можете попробовать это:

Вместо автоматической фильтрации на месте, добавьте лист отчета, используя ссылку «Получить внешние данные» (из той же книги, несмотря на имя!), Которая возвращает требуемый отфильтрованный набор результатов.

Для настройки добавьте соединение: выберите «Данные», «Получить внешние данные», «Другие источники», «Microsoft Query», «Файлы Excel» и выберите свою текущую книгу. (на основе Excel 2010 другие меню в версии Excel немного отличаются)

Настройте запрос на листе «IO data» и включите предложение WHERE (все критерии подойдут, вы отредактируете его с помощью кода позже)

Обновите код _SelectionChange, чтобы изменить запрос на соединение

Вот пример кода для доступа к соединению (предполагается, что в рабочей книге только одно соединение, которое запрашивает набор образцов данных, созданных мной для проверки производительности):

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 секунда </p>

Адаптация этого к вашим требованиям будет в основном строить часть предложения WHERE строки запроса sql, доступной в c.ODBCConnection.CommandText

Answer 2

Возможно, вам придется взглянуть на использование ADO для фильтрации листа. Это должно быть значительно быстрее, но есть некоторая кривая обучения. Начните с этого обзора .

Прежде чем использовать ADO

, вам необходимо добавить ссылку на «Библиотеку объектов данных Microsoft ActiveX 2.8».