Excel在一段时间后停止响应-for循环vba

Question

当我运行以下代码时，excel在一段时间（5-6秒）后停止响应

它的作用：

获取e1中的值，检查是否存在于两张图纸wo或wn中的任何一张上如果是，则将e1获得其值的行移动到另一张图纸wr如果没有找到，则不执行

Option Explicit
Sub RemoveEmail()
Dim wi, wn, wo, wr As Worksheet
Dim e1
Dim FinalRowI, FinalRowN, FinalRowO, FinalRow
Dim i, j
Set wi = Sheet2
Set wn = Sheet3
Set wo = Sheet4
Set wr = Sheet5
FinalRowI = wi.Range("B1048576").End(xlUp).Row
FinalRowN = wn.Range("C1048576").End(xlUp).Row
FinalRowO = wo.Range("C1048576").End(xlUp).Row
FinalRow = WorksheetFunction.Max(FinalRowN, FinalRowO)
For i = 2 To FinalRowI
e1 = Trim(wi.Range("B" & i).Text)
    For j = 2 To FinalRow
        If Trim(wn.Range("C" & j).Text) = e1 Or Trim(wo.Range("C" & j).Text) = e1 Then
         wi.Cells(i, "A").EntireRow.Cut Destination:=wr.Range("A" & wr.Rows.Count).End(xlUp).Offset(1)
        Else: End If
        Application.CutCopyMode = False
    Next j
Next i
End Sub

Answer 1

您不应该检查Range.Text属性，除非有一些单元格格式会更改结果。对于文本（电子邮件…？），Range.Value2属性是最有效的。此外，一旦找到匹配项并xlCut将行从原始行中移出，就没有必要继续循环。继续使用下一个值。

For i = 2 To FinalRowI
    e1 = Trim(LCase(wi.Range("B" & i).Value2))  'unless you have formatting you want to check, .Text is inefficient
    For j = 2 To FinalRow
        If Trim(lcased(wn.Range("C" & j).Value2)) = e1 Or Trim(LCase(wo.Range("C" & j).Value2)) = e1 Then
            wi.Cells(i, "A").EntireRow.Cut Destination:=wr.Range("A" & wr.Rows.Count).End(xlUp).Offset(1)
            Exit For  'you've cut out the row. no need to continue
        End If
        'Application.CutCopyMode = False  'no need for this on a cut
    Next j
Next i

请参阅退出子过程之前是否应重新打开.CutCopyMode？以获取关于为什么CCD_ 6是不必要的更多信息。

建议使用本机工作表COUNTIF函数切换到此方法。

For i = 2 To FinalRowI
    e1 = Trim(wi.Range("B" & i).Value2)
    If CBool(Application.CountIf(wn.Columns(3), e1)) Or CBool(Application.CountIf(wr.Columns(1), e1)) Then
        wi.Cells(i, "A").EntireRow.Cut _
          Destination:=wr.Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
Next i

MATCH函数甚至更有效，但您必须测试两次IsError（每个工作表一次）。