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

当我运行以下代码时，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

---

除非某些单元格格式会更改结果，否则不应检查。对于文本（电子邮件…？）而言，是最有效的。此外，一旦找到匹配项并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

有关为什么不需要

Application.CutCopyMode=False

的更多信息，请参阅

建议使用本机工作表切换到此方法

---

该方法甚至更有效，但您必须测试两次（每个工作表一次。

如果您只是在wn或wo中检查wi中是否存在值，有几种更有效的方法来查找它，而不是在每一行中循环。立即想到匹配或甚至计数。@Jeeped，但这不是我想将匹配数据从

wi

移动到的唯一目的

wr

当然可以。如果找到了，则将其移动到另一个循环。但是，第二个（内部）循环可能会更高效。目前，当以低效的方式找到时，您甚至不会退出该循环。非常感谢您的帮助：D

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