历遍表格删除行数据的问题

dfshm

附件 历遍工作表删除行数据附件.rar (944.35 KB, 下载次数: 12)

2024-7-6 15:21 上传

点击文件名下载附件

谢谢各位老师！

shiruiqiang

遍历表，从最后往前 step-1，如果c、e不同，就删除

小凡、、、

数据太多，测试这样有点慢

feilanga

yanglinzi

1. Sub 删除指定行()
   
2. Dim arr, brr, i, j, r, c, n
   
3. Application.DisplayAlerts = False
   
4. For Each sh In Sheets
   
5.     x = sh.Name
   
6.     With sh
   
7.         r = .Cells(Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a1:e" & r)
   
9.         For i = r To 1 Step -1
   
10.             If .Cells(i, "c") <> .Cells(i, "e") Then
    
11.                 .Rows(i).Delete
    
12.             End If
    
13.         Next
    
14.     End With
    
15. Next
    
16. Application.DisplayAlerts = True
    
17. End Sub
    

复制代码

yanglinzi

参与一下。。

680926

Sub T()
Dim arr
Dim sht As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sht In Sheets
    m = sht.Name
    sht.Select
    arr = sht.Range("a1").CurrentRegion
    For i = UBound(arr) To 1 Step -1
        If arr(i, 3) <> arr(i, 5) Then
            sht.Range("a" & i, Range("e" & i)).Delete
        End If
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ykcbf1100

参与一下，数组法，速度更快。

ykcbf1100

删除行，数组法

1. Sub ykcbf()   '//2024.7.6
   
2.     For Each sht In Sheets
   
3.         With sht
   
4.             r = .Cells(Rows.Count, 1).End(3).Row
   
5.             arr = .[a1].Resize(r, 5)
   
6.             ReDim brr(1 To r, 1 To 5)
   
7.             .[a1].Resize(r, 5).ClearContents
   
8.             m = 0
   
9.             For i = 1 To UBound(arr)
   
10.                 If arr(i, 3) = arr(i, 5) Or arr(1, 2) = arr(i, 3) 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.             .[a1].Resize(m, 5) = brr
    
18.         End With
    
19.     Next
    
20.     MsgBox "OK！"
    
21. End Sub
    

复制代码