无法在更改事件中运行子项

Question

我有一个更改事件代码，该代码会自动添加日期/时间，复制公式，锁定超过24小时的单元格，保护工作表并保存工作簿。这很好。我有一个SUB SUM（），它是一个循环内的循环，用于计算总时间并根据条件填充某些单元格。这很好。在未激活更改事件的情况下开发的SUB SUM（）。我需要他们一起工作，但我似乎不知道该怎么做。我在更改事件代码内的不同点调用了SUB SUM（），它始终锁定。错误包括“数据类型不匹配”和“堆栈已满”，或者循环不断。我认为问题在于每次SUB（SUM）写入一个值时，事件触发器就会启动，并且由于事件触发器保护了单元格，因此SUB无法运行。我在循环的每个阶段都放入了UNPROTECT行。这样，我可以通过调用它来使SUB（SUM）在事件更改处于活动状态时运行，但是它非常慢，并且仍然锁定一半的时间。我猜想我需要更改相交范围以不包括在SUB SUM（）中进行计算的位置。我真的不知道，也不知道如何限制相交范围。任何帮助表示赞赏。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    ActiveSheet.UNPROTECT password:="LS"

    If Not Intersect(Target, Columns("A"), Target.Parent.UsedRange) Is Nothing Then
        On Error GoTo Safe_Exit
        Application.EnableEvents = False
        Dim rng As Range
        For Each rng In Intersect(Target, Columns("A"), Target.Parent.UsedRange)
            If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 4).Value2)) Then
                rng.Offset(0, 4) = Now
                Range(rng.Offset(-1, 5), rng.Offset(-1, 8)).Copy rng.Offset(0, 5)
                ActiveCell.Offset(1, -8).Select

    ActiveWorkbook.Save 

            ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 1).Value2)) Then
                rng.Offset(0, 1) = vbNullString
            End If
         Next rng
    End If

    ' locks entries greater than 24 hrs

    Range("ENTRIES").Locked = False

    Dim LR As Integer
    Dim i As Integer

    LR = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To LR

        If DateDiff("h", CDate(Cells(i, 5).Value), CDate(Format(Now(), "mm/dd")) + TimeSerial(7, 0, 0)) > 24 Then
            Range(Cells(i, 1), Cells(i, 5)).Locked = True
        End If
    Next i

    ActiveSheet.Protect password:="LS"

       'This statement will save when entry is deleted
    ActiveWorkbook.Save
Safe_Exit:'
Application.EnableEvents = True'

End Sub

    Sub SUM()

    Sheet6.Activate
        'ActiveSheet.UNPROTECT password:="LS"
        'Range("ENTRIES").Locked = False

    Dim LR As Integer
    Dim MI As Variant
    Dim DT As Variant
    Dim TM As Double
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim rng As Range

    LR = Cells(Rows.Count, 1).End(xlUp).Row
    For a = 2 To LR

        'ActiveSheet.UNPROTECT password:="LS"
        'Range("ENTRIES").Locked = False

        MI = Cells(a, 1).Value
        DT = Cells(a, 9).Value
        If Cells(a, 8) = "" Then GoTo SafeExit
        TM = Cells(a, 8).Value

        c = a

        For b = a + 1 To LR

        'ActiveSheet.UNPROTECT password:="LS"
        'Range("ENTRIES").Locked = False

                If Cells(b, 8) = "" Then
                    End If
                If Cells(b, 1).Value = MI And Cells(b, 9).Value = DT Then
                    TM = TM + Cells(b, 8).Value
                ElseIf Cells(b, 1).Value = MI And Cells(b, 9).Value <> DT And DT = "RUN" Then
                    Cells(c, 10).Value = TM
                    If Cells(b, 8) = "" Then GoTo SafeExit
                    TM = Cells(b, 8).Value
                    DT = Cells(b, 9).Value
                    c = b
                ElseIf Cells(b, 1).Value = MI And Cells(b, 9).Value <> DT And DT = "EDT" Or Cells(b, 1).Value = MI And Cells(b, 9).Value <> DT And DT = "UDT" Then
                    Cells(c, 11).Value = TM
                    If Cells(b, 8) = "" Then GoTo SafeExit
                    TM = Cells(b, 8).Value
                    DT = Cells(b, 9).Value
                    c = b
                ElseIf Cells(b, 1).Value = MI And Cells(b, 9).Value <> DT And DT = "DT" Then
                    Cells(c, 12).Value = TM
                    If Cells(b, 8) = "" Then GoTo SafeExit
                    TM = Cells(b, 8).Value
                    DT = Cells(b, 9).Value
                    c = b
                ElseIf Cells(b, 1).Value <> MI Then

                End If

        Next b
    Next a
    SafeExit:
End Sub

Answer 1

根据您先前的问题（How to sum cells meeting multiple conditions while starting and stopping loop），您可以将此替代方法用作求和过程。它应该足够快。

Option Explicit

Public Sub CalculateTotalTime()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim iRow As Long
    For iRow = 2 To LastRow
        If ws.Cells(iRow, "D").Value = vbNullString Then 'check if row was already procedured
            'initialize new start
            Dim TotalTime As Double
            TotalTime = ws.Cells(iRow, "B").Value

            Dim CurrentMI As String
            CurrentMI = ws.Cells(iRow, "A").Value

            Dim CurrentDT As String
            CurrentDT = ws.Cells(iRow, "C").Value

            Dim sRow As Long
            sRow = iRow + 1

            Dim Abort As Boolean
            Abort = False
            Do 'Calculate sum until DT of CurrentMI changes
                If ws.Cells(sRow, "A").Value = CurrentMI Then
                    If ws.Cells(sRow, "C").Value = CurrentDT Then
                        TotalTime = TotalTime + ws.Cells(sRow, "B").Value
                        ws.Cells(sRow, "D").Value = "-" 'mark this row as already procedured
                    Else 'change of DT was detected so abort
                        Abort = True
                    End If
                End If
                sRow = sRow + 1
            Loop While Not Abort And sRow <= LastRow

            ws.Cells(iRow, "D").Value = TotalTime 'write total time
        End If
    Next iRow
End Sub