Excel工作表里程碑变更高亮与追踪：VBA代码无响应求助

需求说明 #

• 监控Projekte（或Projects）工作表B列的项目编号（PNR），以及F-I列的里程碑日期（dd-mm-yyyy格式）
• 里程碑日期后移（延期）：单元格标红；前移（提前）：单元格标绿
• 在Tracking工作表按格式Project <PNR>: <单元格地址> 从<date1>变更为<date2>记录所有变更

用户原始失效代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ProjekteSheet As Worksheet
    Dim TrackingSheet As Worksheet
    Dim WatchRange As Range
    Dim ProjekteRange As Range
    Dim Milestone As Range
    Dim ChangeMsg As String
    Dim OldValue As Date
    Dim NewValue As Date
    
    ' Arbeitsblätter festlegen
    Set ProjekteSheet = ThisWorkbook.Sheets("Projekte")
    Set TrackingSheet = ThisWorkbook.Sheets("Tracking")
    
    ' Überwachungsbereich (Spalten F bis I)
    Set WatchRange = Intersect(Target, ProjekteSheet.Range("F:I"))
    
    ' Überprüfen, ob Änderungen in Überwachungsbereich stattgefunden haben
    If Not WatchRange Is Nothing Then
        Application.EnableEvents = False ' Ereignisverarbeitung vorübergehend deaktivieren
        
        ' Durchlaufe jede geänderte Zelle
        For Each Milestone In WatchRange
            ' Überprüfen, ob die geänderte Zelle ein gültiges Datum enthält
            If IsDate(Milestone.Value) Then
                OldValue = Milestone.Value
                NewValue = OldValue
                
                ' Vergleich des alten und neuen Datums
                If OldValue > NewValue Then
                    ' Datum wurde nach vorne verschoben (grün hervorheben)
                    Milestone.Interior.Color = RGB(0, 255, 0) ' Grün
                    ChangeMsg = "hat sich von " & Format(OldValue, "dd.mm.yyyy") & " auf " & Format(NewValue, "dd.mm.yyyy") & " verschoben."
                ElseIf OldValue < NewValue Then
                    ' Datum wurde nach hinten verschoben (rot hervorheben)
                    Milestone.Interior.Color = RGB(255, 0, 0) ' Rot
                    ChangeMsg = "hat sich von " & Format(OldValue, "dd.mm.yyyy") & " auf " & Format(NewValue, "dd.mm.yyyy") & " verschoben."
                Else
                    ' Datum wurde nicht geändert (keine Hervorhebung)
                    ChangeMsg = "bleibt unverändert bei " & Format(NewValue, "dd.mm.yyyy") & "."
                End If
                
                ' Protokollieren der Änderung im Tracking-Arbeitsblatt
                With TrackingSheet
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = "Zelle " & Milestone.Address & " " & ChangeMsg
                End With
            End If
        Next Milestone
        
        Application.EnableEvents = True ' Ereignisverarbeitung wieder aktivieren
    End If
End Sub

核心问题分析 #

1. 事件触发条件不满足：Worksheet_Change事件必须放在**Projekte工作表的代码模块**中（而非标准模块），否则无法响应该工作表的变更操作。
2. 新旧值逻辑完全错误：代码中OldValue = Milestone.Value和NewValue = OldValue导致新旧值完全一致，根本无法对比变更。Worksheet_Change事件本身无法直接获取旧值，必须通过其他事件缓存。
3. 变更记录格式不符合需求：输出的消息格式与要求的Project <PNR>: ...完全不符，且未读取B列对应的PNR。
4. 工作表名称可能不匹配：用户需求中提到的是Projects工作表，但代码中写的是Projekte，需确认是否为语言差异（德语/英语）导致的拼写问题。

修复后的完整代码 #

将以下代码粘贴到**Projekte工作表的代码模块**中（右键工作表标签→查看代码）：

' 全局变量：缓存选中单元格的旧值
Private oldCellValue As Variant
Private oldCellAddress As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 仅缓存F-I列的单元格值，避免多余缓存
    If Not Intersect(Target, Me.Range("F:I")) Is Nothing And Target.Cells.Count = 1 Then
        oldCellValue = Target.Value
        oldCellAddress = Target.Address
    Else
        ' 清空缓存
        oldCellValue = Empty
        oldCellAddress = ""
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim TrackingSheet As Worksheet
    Dim WatchRange As Range
    Dim Milestone As Range
    Dim ChangeMsg As String
    Dim OldValue As Variant
    Dim NewValue As Variant
    Dim pnr As String
    
    ' 禁用事件，避免循环触发
    Application.EnableEvents = False
    
    On Error GoTo ErrorHandler ' 添加错误处理，确保事件能恢复
    
    ' 初始化工作表对象
    Set TrackingSheet = ThisWorkbook.Sheets("Tracking")
    ' 定义监控范围：当前工作表的F-I列
    Set WatchRange = Intersect(Target, Me.Range("F:I"))
    
    If Not WatchRange Is Nothing Then
        For Each Milestone In WatchRange
            ' 仅处理单个单元格变更，且缓存的地址匹配当前单元格
            If Milestone.Address = oldCellAddress Then
                OldValue = oldCellValue
                NewValue = Milestone.Value
                
                ' 仅处理有效的日期变更
                If IsDate(OldValue) And IsDate(NewValue) Then
                    ' 获取对应行的PNR（B列）
                    pnr = Me.Cells(Milestone.Row, "B").Value
                    
                    ' 对比新旧日期并设置单元格颜色
                    If NewValue > OldValue Then
                        ' 延期：标红
                        Milestone.Interior.Color = RGB(255, 0, 0)
                        ChangeMsg = "Project " & pnr & ": " & Milestone.Address & " 从" & Format(OldValue, "dd-mm-yyyy") & "变更为" & Format(NewValue, "dd-mm-yyyy")
                    ElseIf NewValue < OldValue Then
                        ' 提前：标绿
                        Milestone.Interior.Color = RGB(0, 255, 0)
                        ChangeMsg = "Project " & pnr & ": " & Milestone.Address & " 从" & Format(OldValue, "dd-mm-yyyy") & "变更为" & Format(NewValue, "dd-mm-yyyy")
                    Else
                        ' 无变更：清除颜色
                        Milestone.Interior.ColorIndex = xlColorIndexNone
                        ChangeMsg = "Project " & pnr & ": " & Milestone.Address & " 日期未变更"
                    End If
                    
                    ' 写入Tracking工作表（自动追加到最后一行）
                    With TrackingSheet
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = ChangeMsg
                        ' 可选：添加时间戳
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Now()
                    End With
                Else
                    ' 非日期输入：清除颜色并记录
                    Milestone.Interior.ColorIndex = xlColorIndexNone
                    ChangeMsg = "Project " & Me.Cells(Milestone.Row, "B").Value & ": " & Milestone.Address & " 输入无效，非日期格式"
                    TrackingSheet.Cells(TrackingSheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = ChangeMsg
                End If
            End If
        Next Milestone
    End If
    
ErrorHandler:
    ' 恢复事件处理
    Application.EnableEvents = True
    ' 清空缓存
    oldCellValue = Empty
    oldCellAddress = ""
End Sub

修复要点说明 #

1. 添加旧值缓存机制：通过Worksheet_SelectionChange事件提前缓存选中单元格的旧值，解决Worksheet_Change无法获取旧值的问题。
2. 修正事件触发位置：代码必须放在目标工作表的代码模块中，确保能响应变更。
3. 匹配需求的记录格式：读取对应行B列的PNR，生成符合要求的变更消息。
4. 完善错误处理：添加On Error GoTo确保即使出错，事件处理也能恢复启用，避免Excel事件失效。
5. 优化颜色逻辑：无变更时清除单元格背景色，非日期输入时也进行记录。

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