Excel多实例球员价格自动更新VBA代码无响应问题求助

我有一个包含**Player（球员）和Price（价格）**两列的Excel表格，每位球员有多条重复记录。尝试用VBA的Worksheet_Change事件实现：修改某一球员的价格时，所有同球员的价格自动同步更新（比如把某条Messi的价格改成3000，其他Messi的价格也自动变成3000），无需手动运行代码。但执行代码后无任何效果，求排查原因。

原VBA代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
' Define the range to watch (Column B)
Dim rngWatch As Range
Set rngWatch = Me.Range("B:B")

' Check if the changed cell is in the watched range
If Not Intersect(Target, rngWatch) Is Nothing Then
    ' Turn off events to avoid triggering the change event recursively
    Application.EnableEvents = False
    
    Dim iValue As Variant
    Dim sKey As Variant
    Dim searchRange As Range
    Dim foundCell As Range
    Dim cell As Range
    
    ' Loop through the cells in the changed range
    For Each cell In Intersect(Target, rngWatch)
        ' Get the changed value in Column B and the corresponding value in Column A
        iValue = cell.Value
        sKey = Me.Cells(cell.Row, "A").Value
        
        ' Search through Column A for sKey and update the corresponding cells in Column B with iValue
        Set searchRange = Me.Range("A:A")
        Set foundCell = searchRange.Find(What:=sKey, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not foundCell Is Nothing Then
            Do
                foundCell.Offset(0, 1).Value = iValue
                Set foundCell = searchRange.FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Row <> cell.Row
        End If
    Next cell
    
    ' Turn events back on after all changes are made
    Application.EnableEvents = True
End If
End Sub

示例数据 #

核心问题分析 #

1. FindNext循环逻辑漏洞：原代码的循环终止条件Loop While Not foundCell Is Nothing And foundCell.Row <> cell.Row会导致循环提前结束——当找到的下一个单元格是当前修改行时，循环直接停止，遗漏其他同球员的记录。
2. 无异常处理机制：如果代码执行中出错，Application.EnableEvents会保持关闭状态，导致后续所有工作表事件无法触发。
3. 整列遍历效率低：原代码遍历整列A:A，当表格数据量大时会拖慢执行速度，且可能处理空行。

修正后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngWatch As Range
    Set rngWatch = Me.Range("B:B")
    
    ' 仅处理B列的修改
    If Intersect(Target, rngWatch) Is Nothing Then Exit Sub
    
    On Error GoTo ErrorHandler ' 出错时强制恢复事件
    Application.EnableEvents = False
    
    Dim cell As Range
    Dim targetPlayer As String
    Dim newPrice As Variant
    Dim lastRow As Long
    Dim i As Long
    
    ' 获取数据实际最后一行，避免遍历空行
    lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
    
    For Each cell In Intersect(Target, rngWatch)
        targetPlayer = Me.Cells(cell.Row, "A").Value
        newPrice = cell.Value
        
        ' 跳过空球员名的情况
        If targetPlayer = "" Then Continue For
        
        ' 遍历所有数据行，更新同球员的价格
        For i = 1 To lastRow
            If Me.Cells(i, "A").Value = targetPlayer Then
                Me.Cells(i, "B").Value = newPrice
            End If
        Next i
    Next cell

ErrorHandler:
    ' 确保事件始终恢复启用
    Application.EnableEvents = True
    ' 若有错误弹出提示
    If Err.Number <> 0 Then
        MsgBox "执行出错: " & Err.Description, vbExclamation
    End If
End Sub

关键注意事项 #

• 代码存放位置：必须将代码粘贴到对应的工作表模块中（右键工作表标签→查看代码），不能放在标准模块里。
• 文件格式与宏启用：Excel文件需保存为.xlsm格式，打开时必须启用宏才能触发事件。
• 避免批量修改冲突：如果一次性修改多个不同球员的价格，代码会依次处理每个修改项，同步对应球员的所有价格。

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