VBA couleur stylo blanc si AT sinon noir

Le 03/09/2008 à 08:21

bonjour le forum,

j'ai un VBA qui mets le fond de la cellule en couleur si dans ma cellule j'ai les bonne condition, par contre j'aimerai ecrire en blanc si "AT" et saisi par contre laisser noir pour le reste des cellules.

Voici le code que je copie sur chaque feuille est il possible de l'inserer sur le ThisWorkbook ça evite des copies...

Private Sub Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Target, Range("A2:B30")) Is Nothing Then
For Each c In Target
Select Case UCase(c.Value)
Case Is = ""
Target.Interior.ColorIndex =0
Case Is = "AT"
Target.Interior.ColorIndex = 53
Case Is = "F"
Target.Interior.ColorIndex = 39
Case Is = "MAL"
Target.Interior.ColorIndex = 44
Case Is = "MAT"
Target.Interior.ColorIndex = 38
Case Is = "CA"
Target.Interior.ColorIndex = 37
Case Is = "CS"
Target.Interior.ColorIndex = 35
End Select
Next
End If
End Sub

End Sub

cordialement F.

Le 03/09/2008 à 09:13

Bonjour,

Essaye ce code à placer dans THISWORKBOOK

Option Compare Text
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("A2:B30")) Is Nothing Then
Select Case Target
Case Is = ""
Target.Interior.ColorIndex = 0
Case Is = "AT"
With Target
    .Interior.ColorIndex = 53
    .Font.ColorIndex = 2
End With
Case Is = "F"
With Target
    .Interior.ColorIndex = 39
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "MAL"
With Target
    .Interior.ColorIndex = 44
    .Font.ColorIndex = xlAutomatic
End With

Case Is = "MAT"
With Target
    .Interior.ColorIndex = 38
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "CA"
With Target
    .Interior.ColorIndex = 37
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "CS"
With Target
    .Interior.ColorIndex = 35
    .Font.ColorIndex = xlAutomatic
End With
End Select
End If
End Sub

J'ai supprimé la boucle qui n'est pas nécessaire puisque le code s'exécutera directement dès que tu changes une valeur entre A2 et B30.

Amicalement

Dan

Le 03/09/2008 à 09:18

Bonjour,

En modifiant un peu ton code :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim c As Range
If Not Intersect(Target, Range("A2:B30")) Is Nothing Then
For Each c In Target
If c.Value = "AT" Then
Target.Interior.ColorIndex = 53
Target.Font.ColorIndex = 2
Else: Select Case UCase(c.Value)
Case Is = ""
Target.Interior.ColorIndex = 0
Case Is = "F"
Target.Interior.ColorIndex = 39
Case Is = "MAL"
Target.Interior.ColorIndex = 44
Case Is = "MAT"
Target.Interior.ColorIndex = 38
Case Is = "CA"
Target.Interior.ColorIndex = 37
Case Is = "CS"
Target.Interior.ColorIndex = 35
End Select
Target.Font.ColorIndex = 0
End If
Next
End If
End Sub

Effectivement si tu colles le code sous ThisWorkbook (efface ceux des feuilles), ça marchera dans toutes les feuilles du classeur. Si tu veux empêcher sur quelques feuilles on peu ajouter un filtre pour limiter l'exécution de la macro...

P.S : je ne comprends pas trop le code, j'imagine que tu fais des copier-coller de plages dans lesquelles tu n'as qu'une cellule "AT" ou "F" ou...

Si pas ça, alors la procédure doit être simplifiable...

Edit : Salut Dan,

Pour moi la boucle est utile, parce que le target comprend plusieurs cellules, mais faudrait voir le fichier...

Edit 2 : modif de mon code pour le placer dans Thisworkbook

Le 03/09/2008 à 09:39

Merci le forum,

je fais également des copier coller des plages mais avec le code de Nad-Dan qui est a copier sous le THISWORKBOOK cela fonctionne.

f.

Le 03/09/2008 à 09:53

Me suis emmêlé les pinceaux...

J'avais placé mon code dans une feuille pour faire des essais, et celui de Dan dans une autre, puis j'ai oublié de faire la modif...

Par contre le code de Dan t'interdit de faire un copier-coller de plusieurs cellules, ça va planter la macro.

Ou alors faut vraiment que j'arête...

Le 09/09/2008 à 06:22

rebonjour,

alors quel serais l'opération la plus sur pour pour pour me permettre d'utiliser le copie coller

J'ai également un PB lors de la supression des valeurs de la zone:

Quand j'active la macro

Sub efface_Jan()

Range("Jan").ClearContents

End Sub

les couleurs reste?

merci

F.

Le 09/09/2008 à 13:28

Bonjour Clyver,

Si tu n'as pas de formules :

Range("Jan").Clear

Quel copier-coller ?

Amicalement

Dan

Le 09/09/2008 à 15:07

Bonjour,

Lorsque je veux supprimer une couleur il me surligne la ligne (Case Is = "")

merci

Option Compare Text
'© Franck Marian 2008
' Version 1.1 du 01 Septembre 2008

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("I4:AM43")) Is Nothing Then
Select Case Target
Case Is = ""
Target.Interior.ColorIndex = 0
Case Is = "AT"
With Target
    .Interior.ColorIndex = 43
'   .Font.ColorIndex = 2
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "M1"
With Target
    .Interior.ColorIndex = 0
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "M2"
With Target
    .Interior.ColorIndex = 0
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "S1"
With Target
    .Interior.ColorIndex = 0
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "S2"
With Target
    .Interior.ColorIndex = 0
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "MAL"
With Target
    .Interior.ColorIndex = 44
    .Font.ColorIndex = xlAutomatic
End With

Case Is = "MAT"
With Target
    .Interior.ColorIndex = 38
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "CA"
With Target
    .Interior.ColorIndex = 37
    .Font.ColorIndex = xlAutomatic
End With
End Select
End If
End Sub
Le 10/09/2008 à 13:25

Bonjour,

Je ne comprends pas ton soucis. Peux-tu exactement expliquer ce que tu fais ?

A te relire

Dan

Le 10/09/2008 à 16:55

re le forum,

Donc j'ai plusieurs feuilles avec une zone de plage déverouillé ou j'ai des menu ex : AT, M1, M2, S1, S2, MAL, MAT, CA

si j'ai en

I4 = CA J5 = CA K5=CA

quand je selection mes trois cellules puis les Supprimes j'ai une erreur! qui m'envoie sur la ligne

Case Is = ""

Cordialement F.

Le 10/09/2008 à 18:36

Re,

Normal car tu sélectionnes plusieurs cellules.

Corrige ta macro comme ceci.

Juste après :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

mets

If Target.Count > 1 Then Exit Sub

Amicalement

Dan

Le 10/09/2008 à 18:59

re,

OK pour ceci j'ai fait ça :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
 If Not Intersect(Target, Range("I4:AM43")) Is Nothing Then
Select Case Target

ça supprime bien le texte par contre mes cellules coloré le reste?

par contre si je fait (Suppr) dans celle-ci la couleur redevient blanche!

F.

12modelisation-outil-v003.xlsm (38.26 Ko)
Le 10/09/2008 à 19:12

Re,

Remplace le début de ta macro par ceci :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("I4:AM43")) Is Nothing Then
If Target.Count > 1 Then Target.Clear: Exit Sub
Select Case Target

Dan

Le 10/09/2008 à 19:26

OUP'S

La ok mais c'est trop radical car il me supprime tout, il créer une zone blanche j'ai plus les options dans mes cellules (car j'ai 3 conditions en mise en forme conditionnelle) ni accès a cette zone car cette zone devient verouillé...

F.

Le 10/09/2008 à 21:09

re,

A la 2ème ligne, essaie ceci :

If Target.Count > 1 Then Target.ClearContents: Target.Interior.ColorIndex = -4142: Exit Sub

Dan

Le 11/09/2008 à 05:20

Bonjour le Forum,

Merci Nad-Dan pour ton code par contre il y a un pb pour supprimer ma zone ("I4:AM43") il faut attendre 25 secondes par feuille j'en ai 12 pas si cool...

cordialement F.

Le 11/09/2008 à 08:28

Re,

Essaie ceci :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo fin
If Not Intersect(Target, Range("I4:AM43")) Is Nothing Then
Application.EnableEvents = False
With Target
If .Count > 1 Then
    .ClearContents
    .Interior.ColorIndex = -4142
    Application.EnableEvents = True
Exit Sub
End If
End With
Select Case Target
Case Is = ""
Target.Interior.ColorIndex = 0
Case Is = "AT"
With Target
    .Interior.ColorIndex = 43
'   .Font.ColorIndex = 2
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "M1", "M2", "S1", "S2"
With Target
    .Interior.ColorIndex = 0
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "MAL"
With Target
    .Interior.ColorIndex = 44
    .Font.ColorIndex = xlAutomatic
End With

Case Is = "MAT"
With Target
    .Interior.ColorIndex = 38
    .Font.ColorIndex = xlAutomatic
End With
Case Is = "CA"
With Target
    .Interior.ColorIndex = 37
    .Font.ColorIndex = xlAutomatic
End With
End Select
Application.EnableEvents = True
End If
Exit Sub
fin: Application.EnableEvents = True
End Sub

J'ai raccourci le code pour les valeurs M1, M2, S1, S car la couleur est identique pour ces valeurs.

Si pb, place ton fichier car comme tu le vois c'est toujours un peu le parcours du combattant pour arriver à ce qui convient.

Amicalement

Dan

Le 11/09/2008 à 11:03

Salut Dan,

Je te remercie pour ton aide sur cette application, tout fonctionne sur ce fichier.

Bonne journée

cordialement Franck

Rechercher des sujets similaires à "vba couleur stylo blanc sinon noir"