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

如何解决vba 工作表更改事件在某些情况下不起作用

我需要帮助

我做了一个工作表事件，这里是代码：

 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,Cells(12,Columns.Count).End(xlToLeft).Column))
 Set ut3 = ActiveSheet.Range(ActiveSheet.Cells(15,Cells(15,Columns.Count).End(xlToLeft).Column))
 Set ut4 = ActiveSheet.Range(ActiveSheet.Cells(18,Cells(18,Columns.Count).End(xlToLeft).Column))
 Set ut5 = ActiveSheet.Range(ActiveSheet.Cells(21,Cells(21,Columns.Count).End(xlToLeft).Column))
 Set ut6 = ActiveSheet.Range(ActiveSheet.Cells(25,Cells(525,Columns.Count).End(xlToLeft).Column))
 Set ut7 = ActiveSheet.Range(ActiveSheet.Cells(28,Cells(28,Columns.Count).End(xlToLeft).Column))
 Set ut8 = ActiveSheet.Range(ActiveSheet.Cells(31,Cells(31,Columns.Count).End(xlToLeft).Column))
 Set ut9 = ActiveSheet.Range(ActiveSheet.Cells(34,Cells(34,Columns.Count).End(xlToLeft).Column))
 Set ut10 = ActiveSheet.Range(ActiveSheet.Cells(44,Cells(44,Columns.Count).End(xlToLeft).Column))
 Set ut11 = ActiveSheet.Range(ActiveSheet.Cells(47,Cells(47,Columns.Count).End(xlToLeft).Column))
 Set ut12 = ActiveSheet.Range(ActiveSheet.Cells(50,Cells(50,Columns.Count).End(xlToLeft).Column))
 Set ut13 = ActiveSheet.Range(ActiveSheet.Cells(53,Cells(53,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,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,Cells(riga,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,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

代码需要在范围内更改值时触发，并且它工作正常，但是如果我选择的值多于一列并清除内容，则 sub 执行 exit sub，但它再也不会工作了，我必须关闭工作簿并重新打开以便再次工作。

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

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

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

希望你能帮到我

提前致谢

解决方法

工作表更改

• 未经测试。

代码

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),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