excel - vba 工作表更改事件在某些情况下不起作用

Question

我需要帮助

我在这里做了一个工作表事件是代码:

 Private Sub Worksheet_Change(ByVal target As Range)
 Application.EnableEvents = False



 Dim ut1 As Range
 Dim ut2 As Range
 Dim ut3 As Range
 Dim ut4 As Range
 Dim ut5 As Range
 Dim ut6 As Range
 Dim ut7 As Range
 Dim ut8 As Range
 Dim ut9 As Range
 Dim ut10 As Range
 Dim ut11 As Range
 Dim ut12 As Range

 Set ut1 = ActiveSheet.Range(ActiveSheet.Cells(9, "g"), Cells(9, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut2 = ActiveSheet.Range(ActiveSheet.Cells(12, "g"), Cells(12, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut3 = ActiveSheet.Range(ActiveSheet.Cells(15, "g"), Cells(15, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut4 = ActiveSheet.Range(ActiveSheet.Cells(18, "g"), Cells(18, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut5 = ActiveSheet.Range(ActiveSheet.Cells(21, "g"), Cells(21, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut6 = ActiveSheet.Range(ActiveSheet.Cells(25, "g"), Cells(525, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut7 = ActiveSheet.Range(ActiveSheet.Cells(28, "g"), Cells(28, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut8 = ActiveSheet.Range(ActiveSheet.Cells(31, "g"), Cells(31, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut9 = ActiveSheet.Range(ActiveSheet.Cells(34, "g"), Cells(34, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut10 = ActiveSheet.Range(ActiveSheet.Cells(44, "g"), Cells(44, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut11 = ActiveSheet.Range(ActiveSheet.Cells(47, "g"), Cells(47, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut12 = ActiveSheet.Range(ActiveSheet.Cells(50, "g"), Cells(50, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))
 Set ut13 = ActiveSheet.Range(ActiveSheet.Cells(53, "g"), Cells(53, ActiveSheet.Cells(5, 
 Columns.Count).End(xlToLeft).Column))


 If target.Columns.Count > 1 Then Exit Sub







 If Not Intersect(target, Union(ut1, ut2, ut3, ut4, ut5, ut6, ut7, ut8, ut9, ut10, ut11, ut12, ut13)) 
 Is Nothing Then
    Call oresett(target)
  End If

 Application.EnableEvents = True

  End Sub

这里是子

Sub oresett(target As Range)

Dim oreturno As New Dictionary

Dim codifica As Range


Set codifica = Foglio1.Range("ai2:aj" & Foglio1.Cells(Rows.Count, "ai").End(xlUp).Row)

For i = 1 To codifica.Rows.Count
    oreturno.Add UCase(codifica.Cells(i, 1).Value), codifica.Cells(i, 2).Value

Next i

Dim data As Range
Set data = ActiveSheet.Range(ActiveSheet.Cells(5, "g"), Cells(5, ActiveSheet.Cells(5, Columns.Count).End(xlToLeft).Column))

Dim utente As Range
Dim riga As Long

riga = target.Row

Set utente = ActiveSheet.Range(ActiveSheet.Cells(riga - 1, "g"), Cells(riga, ActiveSheet.Cells(5, Columns.Count).End(xlToLeft).Column))

Dim tot As Long
Dim r As Long

tot = ActiveSheet.Cells(target.Row, "c").Value
r = 1
For i = 1 To utente.Columns.Count
    If InStr(UCase(utente.Cells(r, i).Value), UCase("x")) > 0 Then
            r = 2
        End If
        
        If InStr(UCase(data.Cells(1, i).Value), UCase("lun")) = 0 Then
            tot = oreturno(UCase(utente(r, i).Value)) + tot
            Else
            tot = oreturno(UCase(utente(r, i).Value))
            End If
                    If tot > 48 Then
                       MsgBox "superato limite delle 48 ore, riferimento cella" & " " & utente.Range(Cells(r, i), Cells(r, i)).Address
                        Exit Sub
                        
                        
                        'Else
'                        utente.Cells(r, i).Interior.ColorIndex = -4142
                    End If
     
            
        r = 1
        
        
Next i

i = ActiveSheet.Index

If i = 14 Then i = 2

Worksheets(i + 1).Cells(target.Row, "c").Value = tot






End Sub

当一个值在一个范围内发生变化时代码需要触发并且它工作正常但是如果我选择超过一列的值并清除内容子执行退出子但是然后它再也不能工作我必须关闭工作簿并重新打开以便再次工作。

这是一个错误吗？还是我做错了什么？

为了更清楚这里是一张图片

如果我清除黄色部分的一些值，则会发生错误，如果我只删除一个值，则不会。

希望你能帮帮我

提前致谢

Answer 1

工作表更改

• 未经测试。

代码

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rArr As Variant
    rArr = Array(9, 12, 15, 17, 21, 25, 28, 31, 34, 55, 57, 50, 53)
    
    If Target.Columns.Count > 1 Then Exit Sub
    
    Dim cCount As Long: cCount = Me.Columns.Count
    Dim n As Long: n = LBound(rArr)
    Dim rg As Range
    Set rg = Range(Cells(rArr(n), "G"), Cells(rArr(n), cCount).End(xlToLeft))
    For n = n + 1 To UBound(rArr)
        Set rg = Union(rg, _
            Range(Cells(rArr(n), "G"), Cells(rArr(n), cCount).End(xlToLeft)))
    Next n
    
    Set rg = Intersect(Target, rg)
    If rg Is Nothing Then Exit Sub
        
    Application.EnableEvents = False
    On Error GoTo clearError
    oresett rg
        
SafeExit:
    Application.EnableEvents = True
clearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit

End Sub