無法在更改事件中運行子程序

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

根據您之前的問題（ 如何在啟動和停止循環時對滿足多個條件的單元求和），您可以將此替代方法用作求和過程。 它應該足夠快。

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