求助：删除特定行，帮我优化或帮我重新写一个

zzzxxxmmm

食堂流水记录表_删除特定行要求：
整体要求：查找某一列的单元格等于特定值，则删除该单元格所在的整个行数据。
1、E列（部门），含有高的年级，例如高2024级1班、高2024级2班、高2024级3班、高2025级1班、高2025级2班、高2025级3班、高2025级4班、高2026级1班、高2026级2班、高2026级3班、高2026级4班、教师
2、I列（交易班次）中的，晚餐、早餐
3、K列（交易类型）中的，有卡变更、换卡、存款、挂失、补卡、纠错

我自己参考搞的，但数据有很多行（可以上万行），一行一行的循环删除，用时太多太慢。。求大神出手优化为数组，，或帮小弟重新写一个。。谢谢。


代码：

Sub 删除一行()
Dim R As Long
t = Timer
For R = Range("A65536").End(xlUp).Row To 1 Step -1
If InStr(Range("I" & R), "晚餐") + InStr(Range("I" & R), "早餐") + InStr(Range("K" & R), "存款") + InStr(Range("K" & R), "挂失") + InStr(Range("K" & R), "换卡") _
+ InStr(Range("E" & R), "教师") + InStr(Range("E" & R), "高2024级1班") + InStr(Range("E" & R), "高2024级2班") + InStr(Range("E" & R), "高2024级3班") _
+ InStr(Range("E" & R), "高2025级1班") + InStr(Range("E" & R), "高2025级2班") + InStr(Range("E" & R), "高2025级3班") + InStr(Range("E" & R), "高2025级4班") _
+ InStr(Range("E" & R), "高2026级1班") + InStr(Range("E" & R), "高2026级2班") + InStr(Range("E" & R), "高2026级3班") + InStr(Range("E" & R), "高2026级4班") _
+ InStr(Range("K" & R), "有卡变更") + InStr(Range("K" & R), "补卡") + InStr(Range("K" & R), "纠错") _
Then      
      Rows(R).delete Shift:=xlUp
    End If
Next
MsgBox "OK" & "  耗时:  " & Timer - t & "秒！"
End Sub

zzzxxxmmm

求大神出手，帮帮我。谢谢。

cyq4896

参与一下....

chxw68

1. Sub test()
   
2.     Dim r&, i&
   
3.     Dim arr, brr
   
4.     Dim reg1 As New RegExp
   
5.     Dim reg2 As New RegExp
   
6.     Dim reg3 As New RegExp
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     With reg1
   
10.         .Global = False
    
11.         .Pattern = "高2024级1班|高2024级2班|高2024级3班|高2025级1班|高2025级2班|高2025级3班|高2025级4班|高2026级1班|高2026级2班|高2026级3班|高2026级4班|教师"
    
12.     End With
    
13.     With reg2
    
14.         .Global = False
    
15.         .Pattern = "晚餐|早餐"
    
16.     End With
    
17.     With reg3
    
18.         .Global = False
    
19.         .Pattern = "有卡变更|换卡|存款|挂失|补卡|纠错"
    
20.     End With
    
21.     With Worksheets("sheet1")
    
22.         .AutoFilterMode = False
    
23.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
25.         arr = .Range("a2").Resize(r - 1, c)
    
26.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
27.         m = 0
    
28.         For i = 1 To UBound(arr)
    
29.             If Not reg1.test(arr(i, 5)) And Not reg2.test(arr(i, 9)) And Not reg3.test(arr(i, 11)) Then
    
30.                 m = m + 1
    
31.                 For j = 1 To UBound(arr, 2)
    
32.                     brr(m, j) = arr(i, j)
    
33.                 Next
    
34.             End If
    
35.         Next
    
36.         .Range("a2").Resize(r - 1, c).Clear
    
37.         .Columns("c:d").NumberFormatLocal = "@"
    
38.         .Columns("g:g").NumberFormatLocal = "@"
    
39.         If m > 0 Then
    
40.             .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
41.         End If
    
42.     End With
    
43. End Sub
    
44. 
    

复制代码

chxw68

用数组要快一些。

zzzxxxmmm

谢谢各位大神。。。太好了

cnmlgb9998

PQ 一步到位。。。。。。。。。。

zzzxxxmmm

chxw68 发表于 2024-4-23 08:51
用数组要快一些。

请问大神，我下载你的附件可以运行，而复制代码到我原来的表里，就会出错，这是为什么？谢谢解答。

zzzxxxmmm

cnmlgb9998 发表于 2024-4-23 10:04
PQ 一步到位。。。。。。。。。。

不懂啥子PQ,,,还是要谢谢。

chxw68

改为后期邦定了。