Can't run a sub within a change event

Question

I have a change event code that automatically adds a date/time, copies down formulas, locks cells older than 24 hours, protects the sheet and saves the workbook. This works fine. I have a SUB SUM() that is a loop within a loop that calculates total time and populates certain cells based on criteria. This works fine. The SUB SUM() as developed without the change event active. I need them to work together and I can't seem to figure out how. I've called the SUB SUM() at different points within the change event code and it always locks up. Errors include "data type mismatch" and "stack is full", or it loops endlessly. I think the issue is every time the SUB (SUM) writes a value, the event trigger starts and since the event trigger protects cells, the SUB can't run. I put in UNPROTECT lines at each stage of the loop. With this I can get the SUB (SUM) to run with the event change active by calling it but it is very slow and still locks up half the time. I'm guessing I need to change the intersect range to not include where the calculations in the SUB SUM() are being made. I really don't know though and don't know how to limit the intersect range. Any help is appreciated.

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

According to your previous question (How to sum cells meeting multiple conditions while starting and stopping loop) you can use this alternative as sum procedure. It should be quick enough.

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