Trigger macro when any cell containing formula changes

后端 未结 2 1175
误落风尘
误落风尘 2021-01-27 22:49

I have a worksheet with about 50 cells (containing formulas) that changes depending on cells in an external workbook.

I want to trigger a certain macro when ANY of these

相关标签:
2条回答
  • 2021-01-27 23:29

    Maybe you can start with this code.

    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
    
    0 讨论(0)
  • 2021-01-27 23:30

    You could keep the values of the sheet in memory, and upon each recalculation check which have changed while at the same time updating that array.

    Here is some code, to place in the ThisWorkbook module, that would have such a detection set up for the first sheet (change Sheet1 to whichever sheet you want to monitor):

    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
    

    You could use some If statement(s) in the last routine to filter out only those ranges you are really interested in.

    For All Sheets

    If you need to monitor changes in multiple sheets, you could build your cache to be a collection of 2D arrays, one collection entry per sheet, keyed by its name.

    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
    

    This would work for sheets that exist from the start, not sheets that are added. Of course, that also could be made to work, but you'll get the idea.

    0 讨论(0)
提交回复
热议问题