vba worksheets change event doesn't work in certain conditions

user_7449944 0
Viewed 48

i need help

i did a worksheets event here is the code:

 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

here the 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

the code need to trigger when a value is changed in a range and it works fine but if i select more than a columns of values and clear contents the sub do the exit sub but then it never works again i have to close the workbooks and re open in order to work again.

is that a bug? or did i do something wrong?

to be clearer here is a picture

enter image description here

if i clear some values in the yellow part the error will occur if i delete just one value it will not.

I hope you can help me

thanks in advance

event-handling vba excel
1 Answers

A Worksheet Change

  • Not tested.

The Code

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
user_98140690
Related