如何让工作表变更记录VBA宏保留输入公式而非计算值？

问题说明 #

现有一款用于记录Excel工作表变更的VBA宏，存在如下问题：当用户在单元格输入计算公式（如=1+1）时，宏完成变更记录后，单元格仅显示计算结果2，而非保留输入的原公式=1+1。

问题原因 #

原代码中使用了单元格的.Value属性，该属性对于包含公式的单元格，返回的是公式计算后的数值结果，而非公式本身的文本内容。要保留公式，需要改用.Formula属性来获取和设置单元格内容。

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)

Dim RangeValues As Variant
Dim r As Long
Dim boolOne As Boolean
Dim TgValue

Dim sh As Worksheet
Set sh = Worksheets("changelog")
 sh.Visible = True
 
Dim UN As String
 UN = Application.UserName

sh.Unprotect ""
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
                                     Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Target.Cells.count > 1 Then
        TgValue = extractData(Target)
    Else
        ' 改用Formula获取原公式
        TgValue = Array(Array(Target.Formula, Target.Address(0, 0)))
        boolOne = True
End If
 
 
Application.EnableEvents = False
     Application.Undo
     RangeValues = extractData(Target)
     putDataBack TgValue, ActiveSheet
     If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True

Dim columnHeader As String
Dim rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
    sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = _
            Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
 
sh.Protect ""
sh.Visible = xlSheetVeryHidden
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)

Dim i As Long, arrInt, El
For Each El In arr
    ' 改用Formula设置回原公式
    sh.Range(El(1)).Formula = El(0)
Next

End Sub

Function extractData(rng As Range) As Variant

Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.Cells.count - 1)

For Each a In rng.Areas
    For i = 1 To a.Cells.count
        ' 改用Formula提取原公式
        arr(count) = Array(a.Cells(i).Formula, a.Cells(i).Address(0, 0)): count = count + 1
    Next
Next

extractData = arr

End Function

关键修改点 #

• 在extractData函数中，将a.Cells(i).Value替换为a.Cells(i).Formula，确保提取的是单元格的公式文本而非计算结果
• 在putDataBack子过程中，将sh.Range(El(1)).Value替换为sh.Range(El(1)).Formula，保证恢复到单元格的是原公式
• 在单个单元格处理分支中，将Target.Value替换为Target.Formula，正确获取用户输入的公式内容

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