Excel VBA工作表变更日志代码优化：保留公式并记录新旧公式

以下是修改后的代码，可解决你提到的两个问题：保留单元格公式不转为数值，同时记录公式变更的新旧公式内容：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oldData As Variant, newData As Variant, r As Long
    Dim logSheet As Worksheet: Set logSheet = Worksheets("Log  - Inputs - Divisions")
    Dim userName As String: userName = Application.UserName
    
    ' 初始化日志表头
    If logSheet.Range("A1") = "" Then
        logSheet.Range("A1").Resize(1, 7).Value = Array("时间", "用户名", "变更单元格", "旧内容", "新内容", "内容类型", "工作表名")
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 记录变更后的新数据
    newData = GetCellData(Target)
    ' 撤销变更获取旧数据
    Application.Undo
    oldData = GetCellData(Target)
    ' 恢复变更内容
    RestoreCellData newData, Target.Parent
    Application.EnableEvents = True
    
    ' 写入日志
    For r = 0 To UBound(oldData)
        ' 仅当内容确实变化时记录
        If oldData(r)(1) <> newData(r)(1) Or oldData(r)(0) <> newData(r)(0) Then
            Dim contentType As String
            ' 判断内容类型：公式或数值/文本
            contentType = IIf(newData(r)(0) <> "", "公式", "数值/文本")
            ' 整理旧内容和新内容：公式显示公式文本，非公式显示值
            Dim oldContent As String, newContent As String
            oldContent = IIf(oldData(r)(0) <> "", "公式: " & oldData(r)(0), oldData(r)(1))
            newContent = IIf(newData(r)(0) <> "", "公式: " & newData(r)(0), newData(r)(1))
            
            logSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 7).Value = _
                Array(Now, userName, oldData(r)(2), oldContent, newContent, contentType, Target.Parent.Name)
        End If
    Next r
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

' 获取单元格的公式、显示值和地址
Function GetCellData(rng As Range) As Variant
    Dim cell As Range, arr() As Variant, count As Long
    ReDim arr(rng.Cells.Count - 1)
    
    For Each cell In rng
        ' 存储：(公式文本，显示值，单元格地址)
        arr(count) = Array(IIf(cell.HasFormula, cell.Formula, ""), cell.Value, cell.Address(0, 0))
        count = count + 1
    Next cell
    
    GetCellData = arr
End Function

' 恢复单元格的公式或值
Sub RestoreCellData(arr As Variant, ws As Worksheet)
    Dim item As Variant
    For Each item In arr
        With ws.Range(item(2))
            If item(0) <> "" Then
                ' 有公式则恢复公式
                .Formula = item(0)
            Else
                ' 无公式则恢复值
                .Value = item(1)
            End If
        End With
    Next item
End Sub

关键修改说明 #

• 避免公式被转为数值：
  原代码使用.Value赋值会覆盖公式，修改后通过GetCellData记录单元格是否包含公式，RestoreCellData恢复时，对含公式的单元格使用.Formula属性赋值，确保公式完整保留。
• 记录公式的新旧内容：
  GetCellData同时提取单元格的公式文本（如果存在）和显示值，日志中明确标注内容类型，并直接记录新旧公式的文本，而非计算结果。
• 优化日志可读性：
  新增「内容类型」列，清晰区分变更的是公式还是普通数值/文本，日志信息更直观。

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