XL 2016 Changement couleur cellule sélectionné

[Michest94]

Bonjour,

Comment changer la couleur d'une cellule quand elle est sélectionnée?

Merci à vous

 

[Michest94]

@Michest

voici la nouvelle version. (c'est une version sans MFC)

soan

c'est super cool et pafait soan juste que la sélection orange doit être unique car la couleur ne concerne que la cellule sélectionner pour afficher l'infos sur la partie droite.

 

[soan]

donc même si y'a des groupes différents, faut faire
comme si y'en avait qu'un seul, c'est bien ça ?

soan

 

[Staple1600]

Re

=>Michest
Tu me posais question dans le message#15.
Pas vu l'adaptation du code initial que j'ai posté ce soir dans le message#30?

 

[Michest94]

donc même si y'a des groupes différents, faut faire
comme si y'en avait qu'un seul, c'est bien ça ?

soan

oui on ne peut faire qu'un choix à la fois pour le renvois d'infos sur la page de droite.

 

[Michest94]

Re

=>Michest
Avec cette version, la plage de cellules n'est pas figée
Tu sélectionnes par le biais d'un InputBox.
(Il faut sélectionner les cellules avec la souris quand l'InputBox s'affiche)

Sub Créer_MFC_v2()
Dim Rng As Range
Set Rng = Application.InputBox("Plage de cellules concernées par la MFC?", "Surbrillance Cellue Active", , , , Type:=8)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=ADRESSE(LIGNE();COLONNE())=CELLULE(""adresse"")"
With Rng.FormatConditions(1).Borders
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThin
End With
Rng.FormatConditions(1).Interior.Color = 65535
End Sub

NB:
Il faudra toujours penser à mettre également la procédure évènementielle Selection_Change() dans la feuille.

Merci à toi Staple1600 je regarde et te dis.

 

[Michest94]

Merci à toi Staple1600 je regarde et te dis.

je t'ai répondu

 

[soan]

@Michest

voilà, cette fois c'est ok ! (Michest l'a testé et vérifié)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error GoTo Fin 'pour éviter l'erreur due à ton fichier image sur F:
  Const c01& = 12874308 'couleur 1 : bleu
  Const c02& = 49407    'couleur 2 : jaune
  Dim plg As Range, adresselien$
  Application.ScreenUpdating = 0
  With Target
    If .CountLarge <> 3 Then GoTo 1
    If .Column <> 3 Then GoTo 1
    Set plg = Range("C28:E28, C33:E36, C41:E41, C46:E53")
    If Intersect(Target, plg) Is Nothing Then GoTo 1
    ActiveSheet.Unprotect
    plg.Interior.Color = c01: plg.Font.ColorIndex = 2
    With Range(.Address(0, 0))
      .Interior.Color = c02: .Font.ColorIndex = 0
    End With
    ActiveSheet.Protect
  End With

1 Range("H7").Select
   '... suite du code VBA initial

Fin:
End Sub

soan

 

[Michest94]

je t'ai répondu

Merci à toi j'ai testé ton dernier code cela fonctionne je vais tenté de l'appliqué sur mon projet en cours

 

[Michest94]

@Michest

voilà, cette fois, ça devrait être ok ! je te laisse tester et vérifier.

(c'était pas évident à cause des nombreuses fusions ! )

soan

Ecoute c'est nickel! reste à l'intégrer dans mon classeur en cours je te ferais un retour.
En tout les cas un grand MERCI à toi. de on est passé à ca

 

[soan]

@Michest

ok, merci pour ton retour du post #40 !

j'vais aller dîner , alors j'lirai ton autre retour plus tard...

soan

 

[Michest94]

@Michest

ok, merci pour ton retour du post #40 !

j'vais aller dîner , alors j'lirai ton autre retour plus tard...

soan

Bon appétit, j'ai testé sur mon fichier source cela à l'air parfait faut que je paramètre tout mes liens et c'est TOP!
Petite question ! Eventuellement est ce que je peux revenir vers toi sur d'autres petites énigmes d'excel ! Si oui peut on passé en privé ou par ce fil ...

 

[soan]

@Michest

j'suis ravi qu'ça marche bien sur ton fichier source !

bien sûr, tu peux revenir pour d'autre énigmes excel, mais sur le forum,
car c'est interdit par la charte d'aider en privé ; d'autre part, comme
je ne sais pas tout faire, je ne peux jamais rien garantir d'avance !

(c'est aussi pour ça que j'préfère choisir moi-même mes sujets : j'essaye de répondre
quand c'est dans mes compétences, et si j'en ai le temps)

soan

 

[Michest94]

@Michest

j'suis ravi qu'ça marche bien sur ton fichier source !

bien sûr, tu peux revenir pour d'autre énigmes excel, mais sur le forum,
car c'est interdit par la charte d'aider en privé ; d'autre part, comme
je ne sais pas tout faire, je ne peux jamais rien garantir d'avance !

(c'est aussi pour ça que j'préfère choisir moi-même mes sujets : j'essaye de répondre
quand c'est dans mes compétences, et si j'en ai le temps)

soan

Très bien Soan merci à toi et bonne soirée.

 

[Michest94]

@Michest

voilà, cette fois c'est ok ! (Michest l'a testé et vérifié)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error GoTo Fin 'pour éviter l'erreur due à ton fichier image sur F:
  Const c01& = 12874308 'couleur 1 : bleu
  Const c02& = 49407    'couleur 2 : jaune
  Dim plg As Range, adresselien$
  Application.ScreenUpdating = 0
  With Target
    If .CountLarge <> 3 Then GoTo 1
    If .Column <> 3 Then GoTo 1
    Set plg = Range("C28:E28, C33:E36, C41:E41, C46:E53")
    If Intersect(Target, plg) Is Nothing Then GoTo 1
    ActiveSheet.Unprotect
    plg.Interior.Color = c01: plg.Font.ColorIndex = 2
    With Range(.Address(0, 0))
      .Interior.Color = c02: .Font.ColorIndex = 0
    End With
    ActiveSheet.Protect
  End With

1 Range("H7").Select
   '... suite du code VBA initial

Fin:
End Sub

soan

Bonsoir SOAN,

En fait dans mon projet quand j'applique ton code qui fonctionne très bien pour les couleurs j'ai une fenêtre qui me demande d'ôter la protection quand je veux naviguer sur les items.
Merci.
@+

 

[Michest94]

Bonsoir SOAN,

En fait dans mon projet quand j'applique ton code qui fonctionne très bien pour les couleurs j'ai une fenêtre qui me demande d'ôter la protection quand je veux naviguer sur les items.
Merci.
@+

Re,
Finalement tout est ok j'ai trouvé et ajouter le code mdp dans le code VBA.
Merci à toi
@+