不能 运行 更改事件中的子项
Can't run a sub within a change event
我有一个更改事件代码，它会自动添加 date/time、复制公式、锁定超过 24 小时的单元格、保护 sheet 并保存工作簿。这很好用。我有一个 SUB SUM() ，它是一个循环中的一个循环，它计算总时间并根据条件填充某些单元格。这很好用。在未激活更改事件的情况下开发的 SUB SUM()。我需要他们一起工作，但我似乎不知道该怎么做。我在更改事件代码中的不同点调用了 SUB SUM()，它总是锁定。错误包括 "data type mismatch" 和 "stack is full"，或者无限循环。我认为问题是每次 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
根据您之前的问题 (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
我有一个更改事件代码，它会自动添加 date/time、复制公式、锁定超过 24 小时的单元格、保护 sheet 并保存工作簿。这很好用。我有一个 SUB SUM() ，它是一个循环中的一个循环，它计算总时间并根据条件填充某些单元格。这很好用。在未激活更改事件的情况下开发的 SUB SUM()。我需要他们一起工作，但我似乎不知道该怎么做。我在更改事件代码中的不同点调用了 SUB SUM()，它总是锁定。错误包括 "data type mismatch" 和 "stack is full"，或者无限循环。我认为问题是每次 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
根据您之前的问题 (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