当任何包含公式的单元格发生变化时触发宏

Question

我有一个包含大约 50 个单元格（包含公式）的工作表，这些单元格会根据外部工作簿中的单元格而变化。

我想在这些单元格中的任何一个更改其值时触发某个宏。

Worksheet_change 事件不起作用，并且 Worksheet_Calculate 未引用更改的目标单元格。

我找到了这段代码，但它无济于事，因为它测试是否只有一个单元格值被更改（“A1”）。

Private Sub Worksheet_Calculate()
   Static OldVal As Variant

   If Range("A1").Value <> OldVal Then
      OldVal = Range("A1").Value
      Call Macro
   End If
End Sub

因此，我非常感谢您在寻找解决此问题的方法方面的帮助。

注意：所有包含公式的单元格都被命名为单元格。

Answer 1

您可以将工作表的值保存在内存中，并在每次重新计算时检查已更改的值，同时更新该数组。

这是一些代码，放置在ThisWorkbook 模块中，将为第一张工作表设置这样的检测（将Sheet1 更改为您要监控的任何工作表）：

Dim cache As Variant

Private Sub Workbook_Open()
    cache = getSheetValues(Sheet1)
End Sub

Private Function getSheetValues(sheet As Worksheet) As Variant
    Dim arr As Variant
    Dim cell As Range

    ' Get last cell in the used range
    Set cell = sheet.Cells.SpecialCells(xlCellTypeLastCell)
    ' Get all values in the range between A1 and that cell
    arr = sheet.Cells.Resize(cell.Row, cell.Column)
    If IsEmpty(arr) Then ReDim arr(0, 0) ' Default if no data at all
    getSheetValues = arr
End Function

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim current As Variant
    Dim previous As Variant
    Dim i As Long
    Dim j As Long
    Dim prevVal As Variant
    Dim currVal As Variant

    If Sh.CodeName <> Sheet1.CodeName Then Exit Sub
    ' Get the values of the sheet and from the cache
    previous = cache
    current = getSheetValues(Sh)
    For i = 1 To WorksheetFunction.Max(UBound(previous), UBound(current))
        For j = 1 To WorksheetFunction.Max(UBound(previous, 2), UBound(current, 2))
            prevVal = ""
            currVal = ""
            On Error Resume Next ' Ignore errors when out of array bounds
                prevVal = previous(i, j)
                currVal = current(i, j)
            On Error GoTo 0
            If prevVal <> currVal Then
                ' Change detected: call the function that will treat this
                CellChanged Sheet1.Cells(i, j), prevVal
            End If
        Next
    Next
    ' Update cache
    cache = current
ext:
End Sub

Private Sub CellChanged(cell As Range, oldValue As Variant)
    ' This is the place where you would put your logic
    Debug.Print cell.Address & " changed from '" & oldValue & "' to '" & cell.Value & "'"
End Sub

您可以在最后一个例程中使用一些If 语句来仅过滤掉您真正感兴趣的范围。

对于所有工作表

如果您需要监控多个工作表中的更改，您可以将缓存构建为 2D 数组的集合，每个工作表一个集合条目，并以其名称为键。

Dim cache As Collection

Private Sub Workbook_Open()
    Dim sheet As Worksheet

    Set cache = New Collection
    ' Initialise the cache when the workbook opens
    For Each sheet In ActiveWorkbook.Sheets
        cache.Add getSheetValues(sheet), sheet.CodeName
    Next
End Sub

Private Function getSheetValues(sheet As Worksheet) As Variant
    Dim arr As Variant
    Dim cell As Range

    ' Get last cell in the used range
    Set cell = sheet.Cells.SpecialCells(xlCellTypeLastCell)
    ' Get all values in the range between A1 and that cell
    arr = sheet.Cells.Resize(cell.Row, cell.Column)
    If IsEmpty(arr) Then ReDim arr(0, 0) ' Default if no data at all
    getSheetValues = arr
End Function

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim current As Variant
    Dim previous As Variant
    Dim i As Long
    Dim j As Long
    Dim prevVal As Variant
    Dim currVal As Variant

    ' Get the values of the sheet and from the cache
    previous = cache(Sh.CodeName)
    current = getSheetValues(Sh)
    For i = 1 To WorksheetFunction.Max(UBound(previous), UBound(current))
        For j = 1 To WorksheetFunction.Max(UBound(previous, 2), UBound(current, 2))
            prevVal = ""
            currVal = ""
            On Error Resume Next ' Ignore errors when out of array bounds
                prevVal = previous(i, j)
                currVal = current(i, j)
            On Error GoTo 0
            If prevVal <> currVal Then
                ' Change detected: call the function that will treat this
                CellChanged Sheet1.Cells(i, j), prevVal
            End If
        Next
    Next
    ' Update cache
    cache.Remove Sh.CodeName
    cache.Add current, Sh.CodeName
ext:
End Sub

Private Sub CellChanged(cell As Range, oldValue As Variant)
    ' This is the place where you would put your logic
    Debug.Print cell.Address & " changed from '" & oldValue & "' to '" & cell.Value & "'"
End Sub

这适用于从一开始就存在的工作表，而不是添加的工作表。 当然，这也可以实现，但你会明白的。

Answer 2

也许你可以从这段代码开始。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rIntersect As Range
  Set rIntersect = Intersect(Target, Application.names("NameOfRange").RefersToRange)
  If Not rIntersect Is Nothing Then
    MsgBox "found" '<~ change to your liking
  End If
End Sub