Question

_{向下滚动到 tldr 和 Question ，跳过我的漫漫叙述。}

我有几行和几列带有值；例如A10：G15。在每一行中，紧靠任何单元格右侧的单元格的值取决于该单元格，直至涉及的列的范围。这样，任何单元格右边的单元格的值始终在数值上大于该单元格，或者如果原始单元格为空白则为空白。

要保持这种依赖性，如果要清除A：F中某个单元格中的值，我想清除右侧的任何值，或者如果我向任何其他单元格中输入新值，则要向右侧的其余单元格中逐渐添加一个随机数A：F中的单元格。

样本数据。左上角的7是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

如果清除D12，也应清除E12：G12。
▪如果我在C14中键入一个新值，则D14：G14应该分别收到一个新值，该值是
随机但大于先前值。
▪我可能想清除或粘贴列中的多个值，并希望
例程依次处理每个
。 ▪我有几个不连续的区域（请参见下面的代码示例
中的Union范围），并且希望使用DRY coding样式。

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

此事件驱动的Worksheet_Change处理已更改的每个单元格，但仅直接在右侧修改该单元格，而不修改该行中的其余单元格。保持剩余单元格的工作是通过使事件触发器保持活动状态来实现的，以便在修改右侧的单个单元格时，Worksheet_Change会触发一个事件，该事件以新的Target调用自身。

Question

上面的例行程序似乎运行良好，尽管我做出了最大的/最糟糕的努力，但我尚未破坏我的项目环境的稳定性。那么，如果可以将重复周期控制为有限的结果，那么有意在其自身之上运行Worksheet_Change怎么办？

Answer 1

我认为递归触发变更事件的问题在于，这种方式Excel仅能维持很小的调用堆栈。在80次通话时，它杀死了我的Excel实例。当我将递归外包时，我至少接到了1200个电话，当然在一定程度上增加了冗余：

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

Answer 2

我认为您不需要递归调用，可以按区域，按行读入数组，更改数组并写回工作表：

  Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"

    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
    Dim minC As Long, maxC As Long

    If Not Intersect(Target, Range(RANGE_STR)) Is Nothing Then

    minC = Range(RANGE_STR).Column 'taken form first area
    maxC = 1 + Range(RANGE_STR).Columns.Count 'taken form first area

    For Each ar In Target.Areas
        TargetC = ar.Column
            For Each myRow In ar.Rows
                TargetR = myRow.Row
                MyArr = Range(Cells(TargetR, minC), Cells(TargetR, maxC))
                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

                If Not Intersect(Range(Cells(TargetR, minC), Cells(TargetR, maxC)), Range(RANGE_STR)) Is Nothing Then
                Application.EnableEvents = False
                Range(Cells(TargetR, minC), Cells(TargetR, maxC)) = MyArr
                Application.EnableEvents = True
                End If
            Next myRow
    Next ar
    End If
    End Sub

故意在其自身上运行Worksheet_Change

2 个答案: