VBA条件删除循环不起作用
我在电子表格上运行以下代码：
Do While i <= 100000 If Not Cells(i, 4) = "String" Then Cells(i, 4).EntireRow.Delete End If i = i + 1 Loop 有很多不是 “string”的条目，但不会被删除。
当我将这段代码复制到一张单独的工作表中时，我甚至发现错误“Excel无法用可用资源完成此任务，请select更less的数据或closures其他应用程序”。
我做错了什么是使这个循环不工作？
注：我不能使用自动filter，因为我需要删除基于不符合条件的行。
这是一个基本的algorithm错误。
假设你的程序在第10行上，你可以删除它。 所以，第11行成为第10行，第12行成为第11行，依此类推。 然后你去第11行，跳过第10行，在第11行！
这将工作：
Do While i <= 100000 If Not Cells(i, 4) = "String" Then Cells(i, 4).EntireRow.Delete Else i = i + 1 End If Loop
这是删除一行最糟糕的方法。 原因
- 您正在删除循环中的行
- 您的单元格对象不合格
尝试这个。
同样我在MSDN论坛也回答了类似的问题。 请看这个
尝试这种方式（未经testing）
在下面的代码中，我将最后一行硬编码为100000与上面的链接不同。
Sub Sample() Dim ws As Worksheet Dim i As Long Dim delRange As Range '~~> Set this to the relevant worksheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws For i = 1 To 100000 If .Cells(i, 4).Value <> "String" Then If delRange Is Nothing Then Set delRange = .Rows(i) Else Set delRange = Union(delRange, .Rows(i)) End If End If Next i If Not delRange Is Nothing Then delRange.Delete End With End Sub
注：我假设一个单元格将具有类似的值
String aaa bbb ccc String
如果您有“string”可能在不同情况下或在其他string之间的情况，例如
String aaa STRING ccc dddStringddd
那么你将不得不采取稍微不同的方法，如该链接所示。
自动filter代码：
Sub QuickCull() Dim rng1 As Range Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp)) ActiveSheet.AutoFilterMode = False With Application .DisplayAlerts = False .ScreenUpdating = False End With With rng1 .AutoFilter Field:=1, Criteria1:="<>string" If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _ .Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete End With With Application .DisplayAlerts = True .ScreenUpdating = True End With ActiveSheet.AutoFilterMode = False End Sub
当你想删除行总是最好从底部删除。
Sub DeleteData() Dim r As Long Dim Rng As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With ThisWorkbook.Sheets("sheet1") Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown)) For r = Rng.Rows.Count To 1 Step -1 If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then .Cells(r, 4).EntireRow.Delete End If Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub