Оптимизировать производительность копирования отфильтрованных данных в VBA

Question

У меня есть большая таблица с примерно 100 тысячами строк и 40 столбцами. Мне нужно скопировать некоторые строки в другую книгу на основе условия. Мое условие состоит из массива со строками, которые соответствуют значениям столбца. Примерно так:

cond_list = ["value1", "value2", "value3" ...]

И это условие может соответствовать 5 000 строк или более

Сначала я попробовал простое решение - просто использовать Автофильтр, а затем скопировать видимые ячейки, например:

    ' Filter source data
    src_wks.ListObjects("Table1").Range.AutoFilter _
        Field:=src_wks.ListObjects("Table1").ListColumns("Column1").Index, _
        Criteria1:=cond_list, Operator:=xlFilterValues

    ' Copy and paste
    src_wks.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    dst_wks.Range("A1").PasteSpecial Paste:=xlPasteValues

Фильтрация занимает доли секунды, но затем в этой строке висит код:

src_wks.UsedRange.SpecialCells(xlCellTypeVisible).Copy

Выполнение этой строки занимает более 10 минут. Я должен запустить этот код примерно 20 раз, поэтому он неприемлем.

Я пытался изменить код, следуя этому комментарию: { ссылка }

Я пытался скопировать весь сначала данные, а затем удалите скрытые строки. Например:

    ' Copy and Paste whole table
    dst_wks.UsedRange.Offset(1, 0).Value = ""
    addr = src_wks.UsedRange.Address
    dst_wks.Range(addr).Value = src_wks.UsedRange.Value


    ' Filter data
    dst_wks.ListObjects("Table1").Range.AutoFilter _
        Field:=dst_wks.ListObjects("Table1").ListColumns("Column1").Index, _
        Criteria1:=cond_list, Operator:=xlFilterValues

    ' Remove rest
    Application.DisplayAlerts = False ' Suppress "delete row?" promt
    Dim i, numRows As Long
    numRows = dst_wks.UsedRange.Rows.Count
    For i = numRows To 1 Step -1
        If (dst_wks.Range("A" & i).EntireRow.Hidden = True) Then
            dst_wks.Range("A" & i).Delete
        End If
    Next i
    Application.DisplayAlerts = True

Копирование целых данных занимает менее 2 секунд. Но затем он снова зависает в течение l oop и занимает более 10 минут. У меня нет идей, пожалуйста, помогите.

Answer 1

Я не уверен, как выглядят ваши данные, но, на мой взгляд, неэффективно использовать фильтр. Здесь я опубликую демо для вашей справки. Лучше использовать SQL.

Sub filterProcess()
    Dim filterArray
    Dim conn As Object
    Set conn = CreateObject("adodb.connection")
    strPath = ThisWorkbook.FullName

    If Application.Version < 12 Then
        connString = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & strPath
    Else
        connString = "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties = 'Excel 12.0; HDR=YES;IMEX=0'; Data Source = " & strPath
    End If

    filterArray = Array("ta001", "01", "A")


    conn.Open connString
    strSQL = " SELECT * FROM [a$]  where [title1] = '" & filterArray(0) & "'" & " and [title2] = '" & filterArray(1) & "'" & "and [title3] = '" & filterArray(2) & "'"
    Set rst = conn.Execute(strSQL)
   Worksheets.Add

    For j = 0 To rst.Fields.Count - 1
        Cells(1, j + 1) = rst.Fields(j).Name

    Next

    ActiveSheet.Range("A2").CopyFromRecordset rst

    rst.Close
    conn.Close

    Set conn = Nothing


End Sub

Answer 2

Альтернативный подход (есть несколько способов сделать это) может заключаться в использовании оператора SQL для запроса данных с рассматриваемого листа, а затем копирования его на новый лист. Это может быть предпочтительным, если условия для выбора данных становятся более сложными.

У меня есть настройки данных, подобные этим на Листе 1:

Код

Option Explicit
Private Const adCmdText As Long = 1
Private Const adStateOpen As Long = 1

Public Sub DisplayView(Conditions As String)
    Dim dbField       As Variant
    Dim fieldCounter  As Long
    Dim dbConnection  As Object
    Dim dbRecordset   As Object
    Dim dbCommand     As Object
    Dim OutputSheet   As Excel.Worksheet

    Set dbConnection = CreateObject("ADODB.Connection")
    Set dbRecordset = CreateObject("ADODB.Recordset")
    Set dbCommand = CreateObject("ADODB.Command")

    Set OutputSheet = ThisWorkbook.Worksheets("Sheet2")

    'Do a quick check to determine the correct connection string
    'if one of these don't work, have a look here --> https://www.connectionstrings.com/excel/
    If Left$(ThisWorkbook.FullName, 4) = "xlsm" Then
        dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
    Else
        dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES';"
    End If

    'Open the connection and query
    dbConnection.Open
    With dbCommand
        .ActiveConnection = dbConnection
        .CommandType = adCmdText
        .CommandText = "Select * from [Sheet1$] where Column1 in (" & Conditions & ")" 'Update Sheet where applicable
        Set dbRecordset = .Execute
    End With

    'Clear the Output Sheet
    OutputSheet.Cells.Clear

    'Add Headers to output
    For Each dbField In dbRecordset.Fields
        fieldCounter = fieldCounter + 1
        OutputSheet.Cells(1, fieldCounter).Value2 = dbField.Name
    Next

    'Dump the found records
    OutputSheet.Range("A2").CopyFromRecordset dbRecordset
    If dbConnection.State = adStateOpen Then dbConnection.Close
End Sub

'Run from here
Public Sub ExampleRunner()
    Dim t As Double
    t = Timer
    DisplayView "'value1','value2','value3'" 'Send it a quoted csv of values you are looking for
    Debug.Print "Getting data took: " & Timer - t & " seconds"
End Sub

На моей машине уходит около 4-5 секунд, чтобы получить несколько тысяч записей из общего размера набора данных 100 000.

Answer 3

вы можете попробовать:

• метод из принятого решения вопроса SO, который вы связали

  , то есть: l oop - Areas и работать с Value свойства

• ссылка src_wks.ListObjects("Table1").Range также для операции копирования / вставки значений

следующим образом:

Dim area As Range
With src_wks.ListObjects("Table1").Range ' reference your table Range
    ' Filter referenced range
    .AutoFilter _
        Field:=src_wks.ListObjects("Table1").ListColumns("Column1").Index, _
        Criteria1:=cond_list, Operator:=xlFilterValues

    ' Copy and paste values from each single referenced range "visible" area
    For Each area In .SpecialCells(xlCellTypeVisible).Areas
        With area
            dst_wks.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
        End With
    Next
End With

и если бы вы могли Sort ваш стол, это могло бы значительно ускорить его еще