VBA批量转移最小数据代码报错求助：剩余不足20条无法转移

原代码存在的问题 #

• 固定尝试提取前20个最小值，当剩余数据不足20条时，WorksheetFunction.Small会因引用超出实际数据条数而报错
• 静态指定范围A2:A1000，包含大量空行，造成无效遍历
• 嵌套循环逻辑可能重复处理同一行数据，导致错误

修改后的代码 #

Sub cp()
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim sourceRange As Range
    Dim lastRow As Long
    Dim takeCount As Integer
    Dim i As Integer
    Dim cell As Range
    
    ' 定义工作表对象，避免硬编码名称出错
    Set sourceWs = ThisWorkbook.Worksheets("sheet3")
    Set targetWs = ThisWorkbook.Worksheets("sheet5")
    
    ' 动态获取Sheet3中A列最后一行有数据的行号
    lastRow = sourceWs.Cells(sourceWs.Rows.Count, "A").End(xlUp).Row
    
    ' 如果A2及以下没有数据，直接退出
    If lastRow < 2 Then Exit Sub
    
    ' 确定本次要转移的条数：最多20条，剩余不足20条则取全部剩余
    takeCount = Application.Min(20, lastRow - 1)
    
    ' 清除之前的单元格颜色标记
    sourceWs.Range("A2:A" & lastRow).Interior.Pattern = xlNone
    
    ' 遍历要提取的前takeCount个最小值
    For i = 1 To takeCount
        ' 找到对应最小值的单元格（若有重复值会依次处理）
        On Error Resume Next ' 防止处理中数据被删除导致索引失效
        Set cell = sourceWs.Range("A2:A" & lastRow).Find( _
            What:=Application.WorksheetFunction.Small(sourceWs.Range("A2:A" & lastRow), i), _
            LookIn:=xlValues, _
            LookAt:=xlWhole)
        On Error GoTo 0
        
        If Not cell Is Nothing Then
            ' 标记颜色并转移整行数据（16列）
            cell.Interior.ColorIndex = 4
            cell.Resize(1, 16).Cut _
                Destination:=targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            ' 重新获取最后一行，因为刚才删除了一行数据
            lastRow = sourceWs.Cells(sourceWs.Rows.Count, "A").End(xlUp).Row
            ' 如果剩余数据为空，提前退出循环
            If lastRow < 2 Then Exit For
        End If
    Next i
End Sub

关键修改说明 #

1. 动态范围获取：不再固定A2:A1000，而是根据A列实际有数据的行号确定范围，避免空行干扰
2. 自适应转移条数：通过Application.Min(20, lastRow - 1)计算本次要转移的数量，剩余不足20条时自动取全部剩余
3. 错误处理：添加On Error Resume Next避免因数据动态变化导致的查找报错
4. 实时更新行号：每次转移后重新获取源工作表的最后一行，确保后续遍历的范围准确

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