Running Worksheet_Change on top of itself intentionally

Skip my rambling narrative by scrolling down to tldr and Question.

I have several rows and columns with values; e.g. A10:G15. In each row, the value of the cell immediately to the right of any cell is dependent on that cell up to the extents of the columns involved. In this manner, the value of a cell immediately to the right of any cell is always numerically larger than the cell or blank if the original cell is blank.

To maintain this dependency, I want to clear any values to the right if I clear the value from a cell within A:F or progressively add a random number to the remaining cells to the right if I input a new value into any cell within A:F.

Sample data. The 7 in the top-left is A10.

    A    B     C     D     E     F     G
    7    12    15    19    23    27    28
    4     6    10    14    17    18    22
    8    10    14    18    23    26    31
    8    13    15    18    22    25    30
    8    13    16    18    19    21    24
    0     3     4     9    10    12    16

'similar data in A19:G22 and A26:G30

tldr

    ▪ If I clear D12, E12:G12 should also be cleared.
    ▪ If I type a new value into C14 then D14:G14 should each receive a new value which is
      random but larger than the previous value.
    ▪ I might want to clear or paste in several values in a column and would expect the
      routine to deal with each in turn.
    ▪ I have several of these non-contiguous regions (see Union'ed range in code sample
      below) and would prefer a DRY coding style.

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    'Debug.Print Target.Address(0, 0)
    If Not Intersect(Target, Range("A10:F15, A19:F22, A26:F30")) Is Nothing Then
        Dim t As Range
        For Each t In Intersect(Target, Range("A10:F15, A19:F22, A26:F30"))
            If IsEmpty(t) Then
                t.Offset(0, 1).ClearContents
            ElseIf Not IsNumeric(t) Then
                t.ClearContents
            Else
                If t.Column > 1 Then
                    If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
                        t.ClearContents
                    Else
                        t.Offset(0, 1) = t + Application.RandBetween(1, 5)
                    End If
                Else
                    t.Offset(0, 1) = t + Application.RandBetween(1, 5)
                End If
            End If
        Next t
    End If

End Sub

Code explanation

This event driven Worksheet_Change deals with each cell that has changed but only modifies the cell directly to the right, not the remaining cells in that row. The job of maintaining the remaining cells is achieved by leaving event triggers active so that when that single cell to the right is modified, the Worksheet_Change triggers an event that calls itself with a new Target.

Question

The above routine seems to run fine and I have yet to destabilize my project environment despite my best/worst efforts. So what's wrong with intentionally running a Worksheet_Change on top of itself if the reiteration cycles can be controlled to a finite result?

2 answers

  • answered 2018-07-12 09:09 Franz

    I would argue that what is wrong with recursively triggering the change event is that this way Excel can only sustain a pretty tiny call stack. At 80 calls it killed my Excel instance. When I outsourced the recursion I at least got to a little over 1200 calls, of course adding redundancy to some extent:

    Option Explicit
    Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"
    
    Private Sub Worksheet_Change(ByVal target As Range)
        Application.EnableEvents = False
            Dim t As Range
            If Not Intersect(target, Range(RANGE_STR)) Is Nothing Then
                For Each t In Intersect(target, Range(RANGE_STR))
                    makeChange t
                Next t
            End If
        Application.EnableEvents = True
    End Sub
    
    Sub makeChange(ByVal t As Range)
        If Not Intersect(t, Range(RANGE_STR)) Is Nothing Then
            If IsEmpty(t) Then
                t.Offset(0, 1).ClearContents
                makeChange t.Offset(0, 1)
            ElseIf Not IsNumeric(t) Then
                t.ClearContents
                makeChange t
            Else
                If t.Column > 1 Then
                    If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
                        t.ClearContents
                        makeChange t
                    Else
                        t.Offset(0, 1) = t + Application.RandBetween(1, 5)
                        makeChange t.Offset(0, 1)
                    End If
                Else
                    t.Offset(0, 1) = t + Application.RandBetween(1, 5)
                    makeChange t.Offset(0, 1)
                End If
            End If
        End If
    End Sub
    

  • answered 2018-07-12 12:46 EvR

    I don't think you need recursive calls, read by area, by row, into array, change array and write back to sheet:

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyArr As Variant, TargetR As Long, TargetC As Long, i As Long, ar As Range, myRow As Range
    
    For Each ar In Target.Areas
        TargetC = ar.Column
            For Each myRow In ar.Rows
                TargetR = myRow.Row
                MyArr = Range(Cells(TargetR, 1), Cells(TargetR, 7)) 
                If IsEmpty(MyArr(1, TargetC)) Or Not IsNumeric(MyArr(1, TargetC)) Then
                    For i = TargetC To UBound(MyArr, 2)
                        MyArr(1, i) = Empty
                    Next i
                Else
                    For i = TargetC + 1 To UBound(MyArr, 2)
                        MyArr(1, i) = MyArr(1, i - 1) + Application.RandBetween(1, 5)
                    Next i
                End If
                Application.EnableEvents = False
                If Not Intersect(Range(Cells(TargetR, 1), Cells(TargetR, 7)), Range("A10:F15, A19:F22, A26:F30")) Is Nothing Then
                Range(Cells(TargetR, 1), Cells(TargetR, 7)) = MyArr
                End If
                Application.EnableEvents = True
            Next myRow
    Next ar
    
    End Sub