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

Myaah

XLDnaute Nouveau
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.
 

xUpsilon

XLDnaute Accro
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

XLDnaute Impliqué
Supporter XLD
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

XLDnaute Nouveau
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 ! :)
 

Discussions similaires

Statistiques des forums

Discussions
311 078
Messages
2 076 845
Membres
241 953
dernier inscrit
dave15