每次单元格通过公式更改其值时，如何运行 VBA 代码？

How can I run VBA code each time a cell gets its value changed by a formula?

提问by Cloaky

How can I run a VBA function each time a cell gets its value changed by a formula?

每次单元格通过公式更改其值时，如何运行 VBA 函数？

I've managed to run code when a cell gets its value changed by the user, but it doesn't work when the value is changed due to a formula referencing another cell.

当一个单元格的值被用户更改时，我设法运行代码，但是当由于引用另一个单元格的公式而更改值时，它不起作用。

回答by Alex P

If I have a formula in cell A1 (e.g. = B1 * C1) and I want to run some VBA code each time A1 changes due to updates to either cell B1 or C1 then I can use the following:

如果我在单元格 A1 中有一个公式（例如 = B1 * C1）并且我想在每次 A1 因单元格 B1 或 C1 更新而更改时运行一些 VBA 代码，那么我可以使用以下内容：

Private Sub Worksheet_Calculate()
    Dim target As Range
    Set target = Range("A1")

    If Not Intersect(target, Range("A1")) Is Nothing Then
    //Run my VBA code
    End If
End Sub

---

---

Update

更新

As far as I know the problem with Worksheet_Calculateis that it fires for all cells containing formulae on the spreadsheet and you cannot determine which cell has been re-calculated (i.e. Worksheet_Calculatedoes not provide a Targetobject)

据我所知，问题Worksheet_Calculate在于它会为电子表格上包含公式的所有单元格触发，并且您无法确定哪个单元格已被重新计算（即Worksheet_Calculate不提供Target对象）

To get around this, if you have a bunch of formulas in column A and you want to identify which one has updated and add a comment to that specific cell then I think the following code will achieve that:

为了解决这个问题，如果您在 A 列中有一堆公式，并且您想确定哪个已更新并向该特定单元格添加注释，那么我认为以下代码将实现这一点：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim updatedCell As Range
    Set updatedCell = Range(Target.Dependents.Address)

    If Not Intersect(updatedCell, Range("A:A")) Is Nothing Then
       updatedCell.AddComment ("My Comments")
    End If

End Sub

To explain, for a formula to update, one of the input cells into that formula must change e.g. if formula in A1is =B1 * C1then either B1or C1must change to update A1.

为了解释，对于一个公式来更新，所述输入单元中的一个成式必须改变例如，如果式中的A1是=B1 * C1然后要么B1或C1必须改变更新A1。

We can use the Worksheet_Changeevent to detect a cell change on the s/sheet and then use Excel's auditing functionality to trace the dependents e.g. cell A1 is dependent on both B1and C1and, in this instance, the code Target.Dependents.Addresswould return $A$1for any change to B1or C1.

我们可以使用该Worksheet_Change事件来检测 s/sheet 上的单元格更改，然后使用 Excel 的审计功能来跟踪依赖项，例如单元格 A1 依赖于两者B1，C1并且在这种情况下，代码Target.Dependents.Address将返回$A$1对B1或 的任何更改C1。

Given this, all we now need to do is to check if the dependent address is in column A (using Intersect). If it is in Column A we can then add comments to the appropriate cell.

鉴于此，我们现在需要做的就是检查从属地址是否在 A 列中（使用Intersect）。如果它在 A 列中，我们可以在适当的单元格中添加注释。

Note that this only works for adding comments once only into a cell. If you want to continue to overwrite comments in the same cell you would need to modify the code to check for the existance of comments first and then delete as required.

请注意，这仅适用于向单元格添加一次注释。如果要继续覆盖同一单元格中的注释，则需要修改代码以首先检查注释是否存在，然后根据需要删除。

回答by Gene Skuratovsky

The code you used does not work because the cell changing is not the cell with the formula but the sell... being changed :)

您使用的代码不起作用，因为更改的单元格不是带有公式的单元格，而是销售...正在更改:)

Here is what you shoud add to the worksheet's module:

以下是您应该添加到工作表模块的内容：

(Udated: The line "Set rDependents = Target.Dependents" will rase an Error if there are no dependents. This update takes care of this.)

（更新：如果没有依赖项，“Set rDependents = Target.Dependents”行将引发错误。此更新处理了这一点。）

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rDependents As Range

    On Error Resume Next
    Set rDependents = Target.Dependents
    If Err.Number > 0 Then
        Exit Sub
    End If
    ' If the cell with the formula is "F160", for example...
    If Not Application.Intersect(rDependents, Range("F160")) Is Nothing Then
        Call abc
    End If
End Sub

Private Sub abc()
    MsgBox """abc()"" is running now"
End Sub

You can expand this if there are many dependent cells by seting up an array of cell addresses in question. Then you would test for each address in the array (you can use any looping structure for this) and ran a desited subroutine correcponding to the changed cell (use SELECT CASE...) for this.

如果有许多从属单元格，您可以通过设置有问题的单元格地址数组来扩展它。然后，您将测试数组中的每个地址（您可以为此使用任何循环结构）并为此运行与更改的单元格对应的指定子例程（使用 SELECT CASE...）。

回答by Radek

Here is another way using classes. The class can store cell Initial value and cell address. On calculate event it will compare the address current value with the stored initial value. Example below is made to listen to one cell only ("A2"), but you can initiate listening to more cells in the module or change the class to work with wider ranges.

这是使用类的另一种方法。该类可以存储单元格初始值和单元格地址。在计算事件时，它将地址当前值与存储的初始值进行比较。下面的示例仅用于侦听一个单元格（“A2”），但您可以开始侦听模块中的更多单元格或更改类以使用更广泛的范围。

Class module called "Class1":

名为“Class1”的类模块：

Public WithEvents MySheet As Worksheet
Public MyRange As Range
Public MyIniVal As Variant

Public Sub Initialize_MySheet(Sh As Worksheet, Ran As Range)
    Set MySheet = Sh
    Set MyRange = Ran
    MyIniVal = Ran.Value
End Sub
Private Sub MySheet_Calculate()

If MyRange.Value <> MyIniVal Then
    Debug.Print MyRange.Address & " was changed from " & MyIniVal & " to " & MyRange.Value
    StartClass
End If

End Sub

Initialize the class in normall module.

在 normall 模块中初始化类。

Dim MyClass As Class1

Sub StartClass()
Set MyClass = Nothing
Set MyClass = New Class1
MyClass.Initialize_MySheet ActiveSheet, Range("A2")
End Sub

回答by Adrian__

Here is my code:

这是我的代码：

I know it looks terrible, but it works! Of course there are solutions which are much better.

我知道它看起来很糟糕，但它有效！当然，还有更好的解决方案。

Description of the code:

代码说明：

When the Workbook opens, the value of the cells B15 till N15 are saved in the variable PrevValb till PrevValn. If a Worksheet_Calculate() event occurs, the previous values are compared with the actual values of the cells. If there is a change of the value, the cell is marked with red color. This code could be written with functions, so that he is much shorter and easier to read. There's a color-reset-button (Seenchanges), which resets the color to the previous color.

当工作簿打开时，单元格 B15 到 N15 的值保存在变量 PrevValb 到 PrevValn 中。如果发生 Worksheet_Calculate() 事件，则会将之前的值与单元格的实际值进行比较。如果值发生变化，单元格会被标记为红色。这段代码可以用函数编写，这样他就更短更容易阅读了。有一个颜色重置按钮 (Seenchanges)，可将颜色重置为之前的颜色。

Workbook:

工作簿：

Private Sub Workbook_Open()
PrevValb = Tabelle1.Range("B15").Value
PrevValc = Tabelle1.Range("C15").Value
PrevVald = Tabelle1.Range("D15").Value
PrevVale = Tabelle1.Range("E15").Value
PrevValf = Tabelle1.Range("F15").Value
PrevValg = Tabelle1.Range("G15").Value
PrevValh = Tabelle1.Range("H15").Value
PrevVali = Tabelle1.Range("I15").Value
PrevValj = Tabelle1.Range("J15").Value
PrevValk = Tabelle1.Range("K15").Value
PrevVall = Tabelle1.Range("L15").Value
PrevValm = Tabelle1.Range("M15").Value
PrevValn = Tabelle1.Range("N15").Value
End Sub

Modul:

模块：

Sub Seenchanges_Klicken()
Range("B15:N15").Interior.Color = RGB(252, 213, 180)
End Sub

Sheet1:

表 1：

Private Sub Worksheet_Calculate()
If Range("B15").Value <> PrevValb Then
    Range("B15").Interior.Color = RGB(255, 0, 0)
    PrevValb = Range("B15").Value
End If
If Range("C15").Value <> PrevValc Then
    Range("C15").Interior.Color = RGB(255, 0, 0)
    PrevValc = Range("C15").Value
End If
If Range("D15").Value <> PrevVald Then
    Range("D15").Interior.Color = RGB(255, 0, 0)
    PrevVald = Range("D15").Value
End If
If Range("E15").Value <> PrevVale Then
    Range("E15").Interior.Color = RGB(255, 0, 0)
    PrevVale = Range("E15").Value
End If
If Range("F15").Value <> PrevValf Then
    Range("F15").Interior.Color = RGB(255, 0, 0)
    PrevValf = Range("F15").Value
End If
If Range("G15").Value <> PrevValg Then
    Range("G15").Interior.Color = RGB(255, 0, 0)
    PrevValg = Range("G15").Value
End If
If Range("H15").Value <> PrevValh Then
    Range("H15").Interior.Color = RGB(255, 0, 0)
    PrevValh = Range("H15").Value
End If
If Range("I15").Value <> PrevVali Then
    Range("I15").Interior.Color = RGB(255, 0, 0)
    PrevVali = Range("I15").Value
End If
If Range("J15").Value <> PrevValj Then
    Range("J15").Interior.Color = RGB(255, 0, 0)
    PrevValj = Range("J15").Value
End If
If Range("K15").Value <> PrevValk Then
    Range("K15").Interior.Color = RGB(255, 0, 0)
    PrevValk = Range("K15").Value
End If
If Range("L15").Value <> PrevVall Then
    Range("L15").Interior.Color = RGB(255, 0, 0)
    PrevVall = Range("L15").Value
End If
If Range("M15").Value <> PrevValm Then
    Range("M15").Interior.Color = RGB(255, 0, 0)
    PrevValm = Range("M15").Value
End If
If Range("N15").Value <> PrevValn Then
    Range("N15").Interior.Color = RGB(255, 0, 0)
    PrevValn = Range("N15").Value
End If
End Sub