VBA For循环未正常结束：运行至47715行时无报错停止

尝试通过VBA将上方单元格内容复制到下方单元格，当循环运行至i=47715时，程序无报错提示直接停止运行。使用的代码如下：

Dim i As Long

For i = 40 To 180000
    If Cells(i, 33).Value = "A" And IsEmpty(Cells(i + 1, 33)) = True Then
    Cells(i, 33).Copy Cells(i + 1, 33)
    End If
    If Cells(i, 33).Value = "B" And IsEmpty(Cells(i + 1, 33)) = True Then
    Cells(i, 33).Copy Cells(i + 1, 33)
    End If
    If Cells(i, 33).Value = "C" And IsEmpty(Cells(i + 1, 33)) = True Then
    Cells(i, 33).Copy Cells(i + 1, 33)
    End If
Next i
End Sub

1. 定位停止原因 #

程序无报错停止，大概率是i=47715或i+1=47716的单元格存在异常：

• 检查这两个单元格是否为合并单元格：IsEmpty对合并单元格的判断会失效，需结合.MergeCells属性验证。
• 检查单元格是否包含错误值（如#N/A、#VALUE!）：直接读取错误值会导致程序静默崩溃。
• 检查单元格是否有不可见字符：比如空格、换行符，导致Cells(i,33).Value的匹配判断异常。

2. 代码优化（解决问题+提升效率） #

优化后的代码增加错误捕获、减少重复逻辑、提升运行效率，同时避免静默崩溃：

Sub FillEmptyCells()
    Dim i As Long
    Dim ws As Worksheet
    
    '指定目标工作表，避免依赖ActiveSheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    '关闭屏幕刷新和事件，大幅提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '错误捕获，定位异常位置
    On Error GoTo ErrorHandler
    
    For i = 40 To 180000
        '合并A/B/C的判断逻辑，减少重复代码
        Select Case ws.Cells(i, 33).Value
            Case "A", "B", "C"
                '先判断下一行是否为空，排除合并单元格和错误值
                If ws.Cells(i + 1, 33).Value = "" And Not ws.Cells(i + 1, 33).MergeCells Then
                    '直接赋值代替Copy，效率更高
                    ws.Cells(i + 1, 33).Value = ws.Cells(i, 33).Value
                End If
        End Select
    Next i

Cleanup:
    '恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    '弹出错误提示，显示异常发生的i值
    MsgBox "运行异常，当前i值：" & i & vbCrLf & "错误描述：" & Err.Description
    Resume Cleanup
End Sub

3. 关键优化点说明 #

• 指定工作表：避免Cells默认指向ActiveSheet导致的潜在问题。
• 关闭屏幕刷新：循环18万行时，屏幕刷新会严重拖慢程序，甚至导致假死。
• 直接赋值代替Copy：Copy操作会触发剪贴板和格式复制，效率远低于直接赋值（若不需要复制格式，优先用赋值）。
• 错误捕获：程序崩溃时会弹出具体错误信息和当前i值，快速定位问题单元格。
• 合并判断逻辑：用Select Case替代重复的If语句，代码更简洁易维护。

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