Autres VBA - cumuler 2 Private Sub Worksheet_change(ByVal Target As Range)

Myaah · 24 Mars 2023

Bonjour,

Je souhaiterais cumuler, sur une même page, ces deux codes :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, r, i As Long, ech As Boolean, aux, s$
If Intersect(Target, Range("N3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
t = Range("T1:U49").Value
For i = 2 To UBound(t)
If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
Next i
Range("T1:U49") = t
Range("T1:U49").Sort key1:=Range("U1"), order1:=xlDescending, key2:=Range("T1"), order2:=xlAscending, _
MatchCase:=xlNo, Header:=xlYes
r = Range("T1:U49").Value: Range("T1:U49") = t
For i = 2 To 4
If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
Next i
Range("Q3").ClearContents
If s <> "" Then Range("Q3") = Mid(s, 3)
End sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("N4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
t = Range("V1:W26").Value
For i = 2 To UBound(t)
If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
Next i
Range("V1:W26") = t
Range("V1:W26").Sort key1:=Range("W1"), order1:=xlDescending, key2:=Range("V1"), order2:=xlAscending, _
MatchCase:=xlNo, Header:=xlYes
r = Range("V1:W26").Value: Range("V1:W26") = t
For i = 2 To 4
If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
Next i
Range("Q4").ClearContents
If s <> "" Then Range("Q4") = Mid(s, 3)

End Sub

Sauriez-vous comment je peux m'y prendre ? J'ai compris que l'on ne peut pas cumuler 2 Private Sub Worksheet_Change normalement, cependant ils n'entrent pas "en conflit" et chaque code est associé à des cellules différentes, j'imagine donc bien que cela est possible mais je ne trouve pas comment.

Merci par avance !

Excel 2007 FR.

Dranreb · 24 Mars 2023

Bonjour.
Si une seule cellule est modifiée chaque fois vous pouvez mettre un Select Case Target.Address puis
Case "$N$3" suivi du code de la 1ère
Case "$N$4" suivi de code de la seconde
End Select

xUpsilon · 24 Mars 2023

Bonjour,

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, r, i As Long, ech As Boolean, aux, s$
If Not (Intersect(Target, Range("N3")) Is Nothing) Then
    Application.ScreenUpdating = False
    t = Range("T1:U49").Value
    For i = 2 To UBound(t)
        If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
    Next i
    Range("T1:U49") = t
    Range("T1:U49").Sort key1:=Range("U1"), order1:=xlDescending, key2:=Range("T1"), order2:=xlAscending, _
    MatchCase:=xlNo, Header:=xlYes
    r = Range("T1:U49").Value: Range("T1:U49") = t
    For i = 2 To 4
        If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
    Next i
    Range("Q3").ClearContents
    If s <> "" Then Range("Q3") = Mid(s, 3)
End if

If Not (Intersect(Target, Range("N4")) Is Nothing) Then
    Application.ScreenUpdating = False
    t = Range("V1:W26").Value
    For i = 2 To UBound(t)
        If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
    Next i
    Range("V1:W26") = t
    Range("V1:W26").Sort key1:=Range("W1"), order1:=xlDescending, key2:=Range("V1"), order2:=xlAscending, _
    MatchCase:=xlNo, Header:=xlYes
    r = Range("V1:W26").Value: Range("V1:W26") = t
    For i = 2 To 4
        If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
    Next i
    Range("Q4").ClearContents
    If s <> "" Then Range("Q4") = Mid(s, 3)
End if

End Sub

Comme ceci ?

Bonne journée,

PS : Bonjour Dranreb

AtTheOne · 24 Mars 2023

bonjour à toutes & à tous,
bonjour @Myaah

effectivement un seule procédure Worksheet_Change par feuille :
En t'y prennant de la manière suivante

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
'Tes déclarations
...
If not Intersect(Target, Me.[N3]) is nothing then
    'Actions pour N3
   Exit sub
End if
If not Intersect(Target, Me.[N4]) is nothing then
    'Actions pour N4
   Exit sub
End if
 ...
End Sub

Remarque si Target recouvre N3 et N4 (action sur plusieurs cellules) les deux parties seront exécutées.

Bon courage

Myaah · 24 Mars 2023

xUpsilon à dit:

Bonjour,

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, r, i As Long, ech As Boolean, aux, s$
If Not (Intersect(Target, Range("N3")) Is Nothing) Then
    Application.ScreenUpdating = False
    t = Range("T1:U49").Value
    For i = 2 To UBound(t)
        If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
    Next i
    Range("T1:U49") = t
    Range("T1:U49").Sort key1:=Range("U1"), order1:=xlDescending, key2:=Range("T1"), order2:=xlAscending, _
    MatchCase:=xlNo, Header:=xlYes
    r = Range("T1:U49").Value: Range("T1:U49") = t
    For i = 2 To 4
        If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
    Next i
    Range("Q3").ClearContents
    If s <> "" Then Range("Q3") = Mid(s, 3)
End if

If Not (Intersect(Target, Range("N4")) Is Nothing) Then
    Application.ScreenUpdating = False
    t = Range("V1:W26").Value
    For i = 2 To UBound(t)
        If t(i, 1) = Target Then t(i, 2) = t(i, 2) + 1: Exit For
    Next i
    Range("V1:W26") = t
    Range("V1:W26").Sort key1:=Range("W1"), order1:=xlDescending, key2:=Range("V1"), order2:=xlAscending, _
    MatchCase:=xlNo, Header:=xlYes
    r = Range("V1:W26").Value: Range("V1:W26") = t
    For i = 2 To 4
        If r(i, 2) <> "" And r(i, 2) <> "" Then s = s & " / " & r(i, 1)
    Next i
    Range("Q4").ClearContents
    If s <> "" Then Range("Q4") = Mid(s, 3)
End if

End Sub

Comme ceci ?

Bonne journée,

PS : Bonjour Dranreb

MERCI !!! ça fonctionne parfaitement.
Au top, merci infiniment !

AtTheOne · 27 Mars 2023

Bonjour @Myaah
Peux-tu marquer le post de @xUpsilon comme solution ?
Merci

Autres VBA - cumuler 2 Private Sub Worksheet_change(ByVal Target As Range)

Myaah

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

xUpsilon

XLDnaute Accro

AtTheOne

XLDnaute Accro

Myaah

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Discussions similaires