VBA代码运行至第790行后停止复制数据，求排查修复方案

故障现象 #

用于将下载工作簿（wb）数据同步到记录工作簿（MC）的VBA代码，前790行运行正常，但790行之后，循环变量iloop2持续计数，却不再向MC复制数据，工作表数据在第790行后停止更新。

根源分析 #

1. 固定排序范围导致数据未完全覆盖
   原代码中MC的排序范围硬编码为A11:I2000，当MC中数据超过2000行时，超出部分未被排序。后续循环中，iloop2走到2001行后，MC对应单元格为空，触发wb数据 > 空字符串的判断，导致iloop2持续递增却不执行复制逻辑。

2. 未限定工作表的Range引用
   排序代码中使用Range("B12:B2000")这类未指定工作表的引用，切换工作簿时会错误引用当前激活工作表，导致排序不完整或错误，破坏数据匹配逻辑。

3. Integer变量存在溢出风险
   循环变量iloop、iloop2使用Integer类型，VBA中Integer最大值为32767，后续数据量增大时会直接报错中断程序。

4. 循环未处理MC数据耗尽场景
   当iloop2遍历完MC所有有效数据后，代码未判断MC是否已到末尾，持续递增iloop2，无法触发新数据追加逻辑。

修复方案 #

伪代码逻辑 #

1. 禁用屏幕更新，提升运行效率
2. 声明循环/范围变量为Long类型，避免溢出
3. 为所有Range/Cell引用明确指定所属工作表，取消不必要的Activate/Select操作
4. 动态获取MC和wb的有效数据最后一行，排序时覆盖全部数据
5. 优化循环匹配逻辑：
   a. 遍历wb的每一行有效数据
   b. 当MC当前行无数据时，直接追加wb数据到MC末尾
   c. 当wb数据大于MC当前行，MC指针后移
   d. 当wb数据小于MC当前行，追加wb数据到MC末尾
   e. 当数据匹配，更新MC对应字段并同步到子表
6. 封装子表同步逻辑，减少重复代码
7. 恢复屏幕更新

修复后完整代码 #

Public Sub Checker()
    Application.ScreenUpdating = False
    ' 改用Long类型避免溢出
    Dim iloop As Long, iloop2 As Long
    Dim wbLastRow As Long, mcLastRow As Long
    Dim wb As Workbook, MC As Workbook
    Dim celltxt As String, celltx As String
    Dim LastCellColRef As Long: LastCellColRef = 2
    
    ' 绑定工作簿与工作表（避免依赖激活状态）
    Set MC = Workbooks("Master Final SOs Testing")
    Set wb = Workbooks("Book1 (3)")
    Dim mcFullSheet As Worksheet: Set mcFullSheet = MC.Worksheets("Full")
    Dim wbSheet1 As Worksheet: Set wbSheet1 = wb.Worksheets("Sheet1")
    Dim mcRackSheet As Worksheet: Set mcRackSheet = MC.Worksheets("Rack")
    Dim mcBasketSheet As Worksheet: Set mcBasketSheet = MC.Worksheets("Basket")
    
    ' 动态获取最后一行，排序覆盖全部数据
    mcLastRow = mcFullSheet.Cells(mcFullSheet.Rows.Count, LastCellColRef).End(xlUp).Row
    With mcFullSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=mcFullSheet.Range("B12:B" & mcLastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add2 Key:=mcFullSheet.Range("D12:D" & mcLastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange mcFullSheet.Range("A11:I" & mcLastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    wbLastRow = wbSheet1.Cells(wbSheet1.Rows.Count, LastCellColRef).End(xlUp).Row
    With wbSheet1.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=wbSheet1.Range("B2:B" & wbLastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add2 Key:=wbSheet1.Range("D2:D" & wbLastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wbSheet1.Range("A1:G" & wbLastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    If Not wb Is Nothing Then
        iloop = 2: iloop2 = 12 ' MC数据从第12行开始（对应排序的B12）
        ' 遍历wb所有有效数据
        Do While wbSheet1.Cells(iloop, LastCellColRef) <> ""
            ' 获取当前MC行的值，处理MC数据耗尽的情况
            Dim mcCurrentValue As String
            mcCurrentValue = mcFullSheet.Cells(iloop2, LastCellColRef).Value
            
            ' 情况1：MC当前行无数据，直接追加
            If mcCurrentValue = "" Then
                Call AppendDataToMC(wbSheet1, mcFullSheet, mcRackSheet, mcBasketSheet, iloop, LastCellColRef)
                iloop = iloop + 1
            ' 情况2：wb数据 > MC当前行，MC指针后移
            ElseIf wbSheet1.Cells(iloop, LastCellColRef).Value > mcCurrentValue Then
                iloop2 = iloop2 + 1
            ' 情况3：wb数据 < MC当前行，追加到MC
            ElseIf wbSheet1.Cells(iloop, LastCellColRef).Value < mcCurrentValue Then
                Call AppendDataToMC(wbSheet1, mcFullSheet, mcRackSheet, mcBasketSheet, iloop, LastCellColRef)
                iloop = iloop + 1
            ' 情况4：数据匹配，更新字段
            Else
                ' 更新计划发货日期
                mcFullSheet.Cells(iloop2, 4) = wbSheet1.Cells(iloop, 4)
                celltxt = wbSheet1.Cells(iloop, 1).Value
                celltx = mcFullSheet.Cells(iloop2, 1).Value
                
                ' 处理状态变更：Y（已打包）且原状态为R（货架），移到Basket
                If celltxt = "Y" And celltx = "R" Then
                    mcFullSheet.Cells(iloop2, 1).Value = "B"
                    ' 删除Rack中的对应行
                    Dim rngFound As Range
                    Set rngFound = mcRackSheet.UsedRange.Find(mcFullSheet.Cells(iloop2, LastCellColRef).Value)
                    If Not rngFound Is Nothing Then
                        mcRackSheet.Rows(rngFound.Row).Delete
                    End If
                    ' 同步到Basket
                    Call SyncToSubSheet(mcFullSheet, mcBasketSheet, iloop2)
                End If
                iloop = iloop + 1
                iloop2 = iloop2 + 1
            End If
        Loop
    End If
    
    Application.ScreenUpdating = True
End Sub

' 封装：追加wb数据到MC并同步子表
Private Sub AppendDataToMC(wbSheet As Worksheet, mcFullSheet As Worksheet, mcRackSheet As Worksheet, mcBasketSheet As Worksheet, wbRow As Long, colRef As Long)
    Dim lastMCRow As Long
    lastMCRow = mcFullSheet.Cells(mcFullSheet.Rows.Count, colRef).End(xlUp).Row + 1
    
    ' 复制数据到MC
    mcFullSheet.Range(mcFullSheet.Cells(lastMCRow, colRef), mcFullSheet.Cells(lastMCRow, colRef + 5)).Value = _
        wbSheet.Range(wbSheet.Cells(wbRow, colRef), wbSheet.Cells(wbRow, colRef + 5)).Value
    
    ' 设置状态并同步子表
    If wbSheet.Cells(wbRow, 1).Value <> "Y" Then
        mcFullSheet.Cells(lastMCRow, colRef - 1).Value = "R"
        Call SyncToSubSheet(mcFullSheet, mcRackSheet, lastMCRow)
    Else
        mcFullSheet.Cells(lastMCRow, colRef - 1).Value = "B"
        Call SyncToSubSheet(mcFullSheet, mcBasketSheet, lastMCRow)
    End If
End Sub

' 封装：同步MC数据到子表（Rack/Basket）
Private Sub SyncToSubSheet(mcFullSheet As Worksheet, subSheet As Worksheet, mcRow As Long)
    Dim lastSubRow As Long
    lastSubRow = subSheet.Cells(subSheet.Rows.Count, 1).End(xlUp).Row + 1
    
    subSheet.Cells(lastSubRow, 1).Value = mcFullSheet.Cells(mcRow, 2).Value
    subSheet.Cells(lastSubRow, 2).Value = mcFullSheet.Cells(mcRow, 3).Value
    subSheet.Cells(lastSubRow, 3).Value = mcFullSheet.Cells(mcRow, 4).Value
    subSheet.Cells(lastSubRow, 4).Value = mcFullSheet.Cells(mcRow, 6).Value
    subSheet.Cells(lastSubRow, 5).Value = mcFullSheet.Cells(mcRow, 7).Value
End Sub

修复说明 #

• 动态获取数据最后一行，排序覆盖全部有效数据，避免固定范围限制
• 取消Activate和Select操作，直接绑定工作表引用，避免上下文错误
• 改用Long类型变量，彻底避免溢出风险
• 优化循环逻辑，处理MC数据耗尽的场景，确保新数据能正常追加
• 封装重复代码（追加数据、同步子表），提升代码可读性和维护性

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