excel - 优化复制过滤数据

问题描述

我有一个大约 100k 行和 40 列的表。

我需要将一些行复制到另一个工作簿，该工作簿基于一个包含与列值匹配的字符串的数组。

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

此条件可以匹配 5k 行或更多行。

我尝试了一个简单的解决方案来使用 AutoFilter 并复制可见单元格：

' 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

过滤需要几分之一秒，但随后执行此行需要 10 多分钟。我必须运行此代码 20 次，所以这是不可接受的。

src_wks.UsedRange.SpecialCells(xlCellTypeVisible).Copy

我尝试在此评论之后修改代码： https ://stackoverflow.com/a/22789329/7214068

我尝试先复制整个数据，然后删除隐藏的行：

' 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

复制整个数据只需不到两秒钟。但随后它再次挂起 for 循环并需要 10 多分钟。

标签： excelvba

我不确定您的数据是什么样的，但在我看来，使用过滤器效率不高。在这里，我将发布一个演示供您参考。最好使用 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

excel - 优化复制过滤数据

问题描述

解决方案

推荐阅读