|
未经验证。
- Sub 删除完全相同行()
- Dim arr, rng As Range, d, i&, p$, irow&, x$
- Dim s As Single
- s = Timer
- Application.ScreenUpdating = False
- Set d = CreateObject("scripting.dictionary")
- arr = ActiveSheet.UsedRange
- irow = ActiveSheet.UsedRange.Row
- Set rng = Cells(irow + 1, 4)
- If IsArray(arr) = False Then Exit Sub
- For i = UBound(arr) To 2 Step -1
- x = arr(i, 2) & arr(i, 4)
- If Not d.exists(x) Then d(x) = 1 Else Set rng = Union(rng, Cells(i, 4))
- Next
- rng.EntireRow.Delete
- Application.ScreenUpdating = True
- MsgBox "操作完成!", vbInformation + vbOKOnly, "提示"
- MsgBox "耗时" & Format(Timer - s, "0.00秒"), , "提示"
- End Sub
复制代码 |
|