Excel VBA代码F8可正常运行但F5无法执行，求解决方法

问题描述 #

我的Excel VBA代码用F8单步执行时运行正常，但按F5全量执行就无法正常工作。代码如下：

Sub CheckFileExists()

'Clear content
Windows("FilesExists.xlsm").Activate
    Sheets("FilesExists").Select
    Range("C50").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("C50").Select

Windows("FilesExists.xlsm").Activate
    Sheets("FilesExists").Select
    Set ws = ThisWorkbook.Worksheets("FilesExists")
    
Dim webURL As String
Numrows = Range("B50", Range("B50").End(xlDown)).Rows.Count
Range("B50").Select

With ws
For x = 1 To Numrows
    'delay (3)
    CurrValue = ActiveCell.Value
    webURL = CurrValue
    If IsURLGood(webURL) = True Then
        .Range("C" & (ActiveCell.Row)).Value = "EXISTS"
    Else
        .Range("C" & (ActiveCell.Row)).Value = "CHECK"
    End If
    ActiveCell.Offset(1, 0).Select
    Next
End With
'Improves performance/stability
Call OptimizeCode_End

End Sub

Public Function IsURLGood(URL As String) As Boolean 'Application.Calculation = xlCalculationManual
    Dim WinHttpReq_Today As Object
    Set WinHttpReq_Today = CreateObject("Microsoft.XMLHTTP")
    
    On Error GoTo IsURLGoodError
    WinHttpReq_Today.Open "HEAD", URL
    WinHttpReq_Today.send
    If WinHttpReq_Today.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    'Application.Calculation = xlCalculationAutomatic
    Exit Function
    
IsURLGoodError:
    IsURLGood = False
    'Application.Calculation = xlCalculationAutomatic
End Function

我希望解决这个问题，以便设置自动执行，每日发送邮件告知文件是否存在。提前感谢！

问题分析 #

1. 依赖Select/ActiveCell的不稳定：F5快速执行时，单元格选择操作的速度跟不上代码执行节奏，导致ActiveCell引用出错。
2. XMLHTTP请求未等待响应：单步执行时速度慢，请求能完成响应；F5执行时代码快速推进，可能请求还没返回就判断状态，导致结果错误。
3. 缺少执行前的性能优化：未禁用屏幕刷新、事件触发等，可能干扰代码执行流程。

修改后的代码 #

Sub CheckFileExists()
    ' 开启性能优化
    Call OptimizeCode_Start
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("FilesExists")
    
    ' 清空C列从C50开始的内容
    With ws
        .Range(.Range("C50"), .Range("C50").End(xlDown)).ClearContents
    End With
    
    Dim lastRow As Long
    Dim x As Long
    Dim webURL As String
    
    ' 获取B列实际最后一行（避免空行影响循环次数）
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ' 从B50开始循环到最后一行
    For x = 50 To lastRow
        webURL = ws.Range("B" & x).Value
        If IsURLGood(webURL) Then
            ws.Range("C" & x).Value = "EXISTS"
        Else
            ws.Range("C" & x).Value = "CHECK"
        End If
    Next x
    
    ' 关闭性能优化
    Call OptimizeCode_End
End Sub

Public Function IsURLGood(URL As String) As Boolean
    Dim WinHttpReq_Today As Object
    Set WinHttpReq_Today = CreateObject("Microsoft.XMLHTTP")
    
    On Error GoTo IsURLGoodError
    ' 改为同步请求，确保等待响应完成后再继续
    WinHttpReq_Today.Open "HEAD", URL, False
    WinHttpReq_Today.send
    
    ' 额外等待请求状态完成，避免极端情况
    Do While WinHttpReq_Today.ReadyState <> 4
        DoEvents
    Loop
    
    If WinHttpReq_Today.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    
    Exit Function
    
IsURLGoodError:
    IsURLGood = False
End Function

' 新增性能优化开头函数
Sub OptimizeCode_Start()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
End Sub

' 完善性能优化结尾函数
Sub OptimizeCode_End()
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Sub

关键修改说明 #

1. 移除所有Select/Activate操作：直接通过工作表对象ws引用单元格，彻底避免活动单元格依赖导致的错误。
2. XMLHTTP改为同步请求：Open方法第三个参数设为False，确保请求完成后再执行后续判断；同时添加循环等待请求状态完成，进一步保证响应返回。
3. 优化行号计算：用lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row获取B列实际最后一行，避免空行导致的循环次数错误。
4. 补充完整性能优化函数：新增OptimizeCode_Start禁用屏幕刷新、事件等，提升执行稳定性和速度；完善OptimizeCode_End恢复所有系统设置。
5. 简化循环逻辑：直接用行号x循环，无需移动活动单元格，逻辑更清晰稳定。

修改后F5执行即可和单步执行保持一致结果，适合后续设置自动执行任务。

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