求VBA宏：计算单元格首编日期与当前值的日期差并写入Sheet2

一、需求说明 #

• 流程合规性KPI计算逻辑：计划结束日期 - 实际结束日期
• 计划日期：单元格首次录入的日期（存储在批注的第一条记录中）
• 实际结束日期：单元格当前显示的日期
• 最终结果需写入Sheet2

二、现有批注存储代码（中文注释版） #

原代码用于记录第13列（M列）单元格的每次修改操作（含修改时间、操作人、修改后内容）并保存到批注中，以下是带中文注释的版本：

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        ' 仅处理第13列（M列）的单元格修改
        If Target.Column <> 13 Then Exit Sub
        ' 单元格为空时直接退出
        If IsEmpty(Target) Then Exit Sub
        
        Dim strNewText$, strCommentOld$, strCommentNew$
        strNewText = .Text ' 获取单元格当前内容
        
        ' 若已有批注，保留原有内容并添加换行分隔
        If Not .Comment Is Nothing Then
            strCommentOld = .Comment.Text & Chr(10) & Chr(10)
        Else
            strCommentOld = ""
        End If
        
        ' 删除原有批注并重新创建
        On Error Resume Next
        .Comment.Delete
        Err.Clear
        .AddComment
        .Comment.Visible = False ' 默认隐藏批注
        
        ' 写入新批注内容：原有记录 + 修改时间+操作人 + 修改后内容
        .Comment.Text Text:=strCommentOld & _
            Format(VBA.Now, "MM/DD/YYYY at h:MM AM/PM") & " - " & Application.UserName & Chr(10) & strNewText
        .Comment.Shape.TextFrame.AutoSize = True ' 自动调整批注框大小以适配内容
    End With
End Sub

三、提取计划日期并计算差值的VBA宏 #

以下宏会遍历第13列所有带批注的单元格，提取批注中首次记录的计划日期，与单元格当前的实际日期计算差值，最终将结果写入Sheet2：

Sub CalculateComplianceKPI()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim cell As Range, commentLines As Variant, firstRecordContent As String
    Dim planDate As Date, actualDate As Date, dateDiff As Long
    Dim targetRow As Long
    
    ' 指定源工作表（存储修改记录的表）和目标工作表（Sheet2）
    Set wsSource = ThisWorkbook.ActiveSheet ' 可替换为具体表名，如Sheets("流程跟踪表")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    
    ' 清空Sheet2原有数据（保留表头）
    wsTarget.Range("A2:Z" & wsTarget.Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    targetRow = 2 ' 从第2行开始写入计算结果
    
    ' 遍历源表第13列的所有单元格
    For Each cell In wsSource.Columns(13).Cells
        ' 跳过空单元格和无批注的单元格
        If Not IsEmpty(cell) And Not cell.Comment Is Nothing Then
            ' 按换行符拆分批注内容
            commentLines = Split(cell.Comment.Text, Chr(10))
            
            ' 第一条记录的日期内容在拆分后的第2个元素（每条记录格式：时间-用户名 换行 日期）
            If UBound(commentLines) >= 1 Then
                firstRecordContent = Trim(commentLines(1))
                
                ' 尝试将内容转换为日期格式
                On Error Resume Next
                planDate = CDate(firstRecordContent)
                actualDate = CDate(cell.Value)
                On Error GoTo 0
                
                ' 日期转换成功则计算差值
                If IsDate(planDate) And IsDate(actualDate) Then
                    dateDiff = planDate - actualDate
                    
                    ' 写入Sheet2：零件标识（假设A列是零件编号）、计划日期、实际日期、差值
                    wsTarget.Cells(targetRow, 1).Value = wsSource.Cells(cell.Row, 1).Value
                    wsTarget.Cells(targetRow, 2).Value = planDate
                    wsTarget.Cells(targetRow, 3).Value = actualDate
                    wsTarget.Cells(targetRow, 4).Value = dateDiff
                    
                    targetRow = targetRow + 1
                End If
            End If
        End If
    Next cell
    
    MsgBox "KPI计算完成，结果已写入Sheet2！", vbInformation
End Sub

四、使用步骤 #

1. 打开Excel文件，按Alt+F11进入VBA编辑器
2. 将上述CalculateComplianceKPI宏粘贴到对应模块中
3. 返回Excel界面，按Alt+F8选择该宏执行即可

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