关于按条件筛选值问题

sampsonpon

具体如图：

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.20
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("Bridge_data")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .Range("a1:q" & r)
   
6.         rq = CDate(.[s1].Value)
   
7.     End With
   
8.     ReDim brr(1 To r, 1 To UBound(arr, 2))
   
9.     For i = 2 To UBound(arr)
   
10.         If CDate(arr(i, 17)) > rq Then
    
11.             m = m + 1
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 brr(m, j) = arr(i, j)
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     With Sheets("Picking List Data")
    
18.         .UsedRange.Offset(1).ClearContents
    
19.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "OK！"
    
23. End Sub
    
24. 
    

复制代码

ykcbf1100

你直接操作单元格，速度肯定慢，你数据都快4万行了。
改用数组。

limonet

Sub limonet()
    Sheets("Bridge_data").Columns("A:Q").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("R1:R2"), CopyToRange:=Range("A1"), Unique:=False
End Sub

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select * From [Bridge_data$A:Q] Where [CREATE TO DATE]>#" & Worksheets("Bridge_data").Range("S1") & "#"
    Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

limonet

关键字：where

Qs18

1. Sub qs()
   
2. Dim arr, i, rq
   
3. With Sheet2
   
4.     rw = .Cells(Rows.Count, "q").End(xlUp).Row
   
5.     arr = .Range("a2:q" & rw).Value
   
6.     ReDim brr(1 To rw, 1 To UBound(arr, 2))
   
7.     rq = CDate(.[s1].Value)
   
8.     For i = 1 To UBound(arr)
   
9.     If CDate(arr(i, 17)) > rq Then
   
10.          m = m + 1
    
11.         For j = 1 To UBound(arr, 2)
    
12.             brr(m, j) = arr(i, j)
    
13.         Next j
    
14.     End If
    
15.     Next i
    
16. End With
    
17. Sheet1.Range("a2").Resize(m, UBound(arr, 2)) = brr
    
18. End Sub
    

复制代码

Qs18

试试..........

Qs18

试试........