VBA中For循环持续导致Excel崩溃，寻求解决办法

崩溃原因 #

• 排序操作未指定工作表：Range("B:B").Sort 默认操作当前活动表，而非目标的Yesterday_Kickbacks工作表，导致排序结果不符合预期，后续循环逻辑混乱。
• 逐行复制效率极低：数据量大时，频繁的整行复制粘贴会占用大量系统资源，直接导致Excel崩溃。
• 最后一行计算不准确：Cells(Rows.Count, 2).End(xlDown).Row 如果第2列中间有空值，会错误计算最后一行位置，导致循环范围异常。
• 未启用性能优化：没有关闭屏幕更新、事件触发等，加剧卡顿。

修复后的代码 #

Sub ExtractDuplicateWorkOrders()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, targetRow As Long
    Dim wsNameSource As String, wsNameTarget As String
    
    ' 定义工作表名称
    wsNameSource = "Yesterday_Kickbacks"
    wsNameTarget = "WO_MULTIPLE_KB"
    
    ' 引用工作表对象
    Set wsSource = ThisWorkbook.Sheets(wsNameSource)
    Set wsTarget = ThisWorkbook.Sheets(wsNameTarget)
    
    ' 性能优化：关闭屏幕更新、事件触发
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 复制表头
    wsSource.Rows(1).Copy wsTarget.Range("A1")
    targetRow = 2
    
    ' 对源表第2列排序（指定工作表，避免活动表问题）
    wsSource.Sort.SortFields.Clear
    wsSource.Sort.SortFields.Add Key:=wsSource.Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wsSource.Sort
        .SetRange wsSource.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 准确获取第2列最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, 2).End(xlUp).Row
    
    ' 遍历查找重复项，批量收集后一次性复制（提升效率）
    Dim duplicateRows As Range
    Set duplicateRows = Nothing
    
    For i = 2 To lastRow
        If wsSource.Cells(i, 2).Value = wsSource.Cells(i - 1, 2).Value Then
            If duplicateRows Is Nothing Then
                Set duplicateRows = wsSource.Rows(i)
            Else
                Set duplicateRows = Union(duplicateRows, wsSource.Rows(i))
            End If
        End If
    Next i
    
    ' 一次性复制所有重复行到目标表
    If Not duplicateRows Is Nothing Then
        duplicateRows.Copy wsTarget.Range("A" & targetRow)
    End If
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "重复工单提取完成！", vbInformation
End Sub

关键优化点 #

• 明确工作表引用：所有Range操作都绑定到指定工作表对象，避免活动表切换导致的错误。
• 批量复制替代逐行操作：先收集所有需要复制的行，再一次性粘贴，大幅减少系统资源占用。
• 准确获取最后一行：用End(xlUp)替代End(xlDown)，避免中间空值导致的范围错误。
• 性能优化开关：关闭屏幕更新和事件触发，提升运行速度，避免卡顿崩溃。

内容的提问来源于stack exchange，提问作者andrew