2 événements Worksheet_SelectionChange sur la même feuille

Le 12/07/2017 à 16:21

Bonjour,

Je souhaiterais faire cohabiter sur la même feuille 2 événements Worksheet_SelectionChange, le problème étant que j'ai un conflit de nom.

Voici les 2 Subs (qui n'ont rien à voir).

Je mets le classeurs en pièce jointe.

Merci d'avance 

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'au changement de selection dans l'onglet
Dim Fichier As String
   If Target.Value = "" Then Exit Sub
   If Not Application.Intersect(Target, Range("F8:F54")) Is Nothing Then
        Fichier = "https://www.google.fr/maps/place/" & Target.Value
       Ouvrir Fichier
   End If
End Sub

et

Private TEST As Boolean 'déclare la variable TEST

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'au changement de selection dans l'onglet

Dim PL As Range 'déclare la variable PL

Set PL = Range("A8:A54") 'définit la plage PL
If Intersect(PL, Target) Is Nothing Then Exit Sub 'si le changement a lieu ailleurs que dans la plage PL, sort de la procédure
If Target.Count > 1 Then Exit Sub 'si le changement a lieu dans plusieurs cellules de la plage PL, sort de la procédure
If TEST = True Then Exit Sub 'si TEST est [Vrai], sort de la procédure (je préfère ça à EnableEvents = False)
AV = Target.Value 'définit l'ancienne Valeur AV (déclarée publique dans le module [Tri_plage]
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim PL As Range 'déclare la variable PL
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim LD As Byte 'declare la variable LD (Ligne de Départ)
Dim LF As Byte 'declare la variable LF (Ligne de Fin)
Dim LI As Byte 'declare la variable LI (LIgne)

Set PL = Range("A8:A54") 'définit la plage PL
If Intersect(PL, Target) Is Nothing Then Exit Sub 'si le changement a lieu ailleurs que dans la plage PL, sort de la procédure
If Target.Count > 1 Then Exit Sub 'si le changement a lieu dans plusieurs cellules de la plage PL, sort de la procédure
If TEST = True Then Exit Sub 'si TEST est [Vrai], sort de la procédure (je préfère ça à EnableEvents = False)
If Not IsNumeric(Target.Value) Or 47 < Target.Value Or 1 > Target.Value Then 'condition : si la cellule modifié contient une valeur inférieure à 1 ou supérieure à 40
   MsgBox "Merci de saisir une valeur numérique comprise entre 1 et 40 !!! " 'message
   With Application 'prend en compte l'Application
       .EnableEvents = False 'n'autorise plus les procédures événementielles
       .Undo 'annule de vient d'être fait
       .EnableEvents = True 'autorise les procédure événementielles
   End With 'fin de la prise e compte de l'Apllication
End If 'fin de la condition
TEST = True 'définit la variable TEST
Target.Value = Target.Value \ 1 'si une valeur décimale est éditée, remplace par la valeur entière
If AV < Target.Value Then 'condition : si l'ancienne valeur de la cellule modifiée est inférieure à la nouvelle valeur
   LD = Target.Row + 1 'définit la ligne de départ LD
Else 'sinon
   For Each CEL In PL 'boucle sur toutes les cellules CEL de la plage PL
       'si la valeur de la cellule CEL est égale à la valeur de la cellule modifié et que leur adresse est différente,
       If CEL.Value = Target.Value And CEL.Address <> Target.Address Then LD = CEL.Row: Exit For 'définit la ligne de départ LD et sort de la boucle
   Next CEL 'prochaine cellule de la boucle
End If 'fin de la condition
'LF = IIf(AV > Target.Value, Target.Row - 1, Target.Row + 1) 'définit la ligne de fin LF en fonction de l'ancienne valeur (une ligne au-dessus ou au-dessous de la cellule modifiée)
If AV > Target.Value Then 'condition : si l'ancienne valeur de la cellule modifiée est inférieure à la nouvelle valeur
   LF = Target.Row - 1 'définit la ligne de départ LD
Else 'sinon
   For Each CEL In PL 'boucle sur toutes les cellules CEL de la plage PL
       'si la valeur de la cellule CEL est égale à la valeur de la cellule modifié et que leur adresse est différente,
       If CEL.Value = Target.Value And CEL.Address <> Target.Address Then LF = CEL.Row: Exit For 'définit la ligne de départ LD et sort de la boucle
   Next CEL 'prochaine cellule de la boucle
End If 'fin de la condition
For LI = LD To LF 'boucle sur toutes les ligne LI de LD à LF
   Cells(LI, 1).Value = IIf(AV > Target.Value, Cells(LI, 1).Value + 1, Cells(LI, 1).Value - 1) 'incrémente la cellule ligne Li colonne 1
Next LI 'prochaine ligne de la boucle
If Not Intersect(Target, PL) Is Nothing Then Tri 'lance la procédure [Tri]
Range("A1").Select 'sélectionne la cellule A1
TEST = False 'réinitialise la variable TEST

End Sub
19affectations-possibles-ok.xlsm (37.05 Ko)
Le 12/07/2017 à 17:29

... à suivre ...

Le 12/07/2017 à 17:29

bonjour,

Supprimer les 2 Worksheet_SelectionChange et remplacer par celle-ci :

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'au changement de selection dans l'onglet
Dim Fichier$, S$
If Target.Count = 1 Then
   S = Target.Value
   If S <> "" Then
      If Not Intersect(Target, Range("A8:A54")) Is Nothing Then
         AV = S
      End If

      If Not TEST And Not Application.Intersect(Target, Range("F8:F54")) Is Nothing Then
         Fichier = "https://www.google.fr/maps/place/" & S '' Liens GoogleMaps
         Ouvrir Fichier
      End If
   End If
End If
End Sub

A+

Le 12/07/2017 à 17:30

Galopin m'a grillé ... je le laisse donc terminer cette question.

Le 12/07/2017 à 18:49

Parfait !

Merci à Galopin et au forum

Le 07/08/2018 à 16:27

Salut à tous,

Vos précédentes macros m'ont bien aidé, mais je bloque sur la fonction intersect. Je m'explique:

J'aimerai pouvoir appliquer un zoom sur la case "H11" et sur la sur case "D42" quand elles sont activées (indépendamment), et "dézoomer" lorsqu'elles ne le sont plus.

J'arrive à le faire lorsqu'il n'y a qu'une cellule (ex avec "H11")

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 If Not Intersect(Range("H11"), Target) Is Nothing And Target.Count = 1 Then
    ActiveWindow.Zoom = 80
 Else
    ActiveWindow.Zoom = 60
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  ActiveWindow.Zoom = 60
End Sub

Mais je n'arrive pas à combiner pour que cela fonctionne sur deux cellules...

J'ai essayé quelque chose mais mes compétences sont limitées 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim PL As Range, DL As Range
Set PL = Range("H11")
Set DL = Range("D42")
 If Not Intersect(PL, DL, Target) Is Nothing And Target.Count = 1 Then
    ActiveWindow.Zoom = 80
 Else
    ActiveWindow.Zoom = 60
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  ActiveWindow.Zoom = 60
End Sub

Est-il possible de zoomer et dézoomer sur chacunes des cases ?

Je vous remercie d'avance !

Rechercher des sujets similaires à "evenements worksheet selectionchange meme feuille"