Microsoft 365 Code VBA pour cellule en surbrillance

Bruno09

XLDnaute Nouveau
Bonjour, j'ai un code vba pour mettre en surbrillance la cellule active. Certaines de mes cellules sont d'une autre couleurs que la surbrillance. Le problème est que maintenant je ne peux plus ajouter de la couleur ou changer la couleur de mes cellules.
Est-ce qu'on peut m'aider svp?
Voici le code

Merci
1614892773624.png
 
Solution
En fait avec cette macro qui nomme la cellule active on peut faire cohabiter autant de MFC que l'on veut :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Application.CutCopyMode Then Exit Sub 'si copier/couper
Dim fc As FormatCondition
'---supprime la MFC---
If TypeName([CA]) = "Range" Then
    For Each fc In [CA].FormatConditions
        If fc.Interior.Color = vbBlack Then fc.Delete
    Next
End If
'---crée la MFC---
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
ActiveCell.FormatConditions(ActiveCell.FormatConditions.Count).SetFirstPriority
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold =...

job75

XLDnaute Barbatruc
Bonsoir Bruno09,

En créant une MFC sur la cellule active :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.FormatConditions.Delete 'RAZ
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
End With
End Sub
Mais on ne peut pas créer d'autres MFC sur la feuille.

A+
 

job75

XLDnaute Barbatruc
La macro précédente est à placer dans le code d'une feuille de calcul.

Si on veut l'appliquer à toutes les feuilles du classeur placer dans ThisWorkbook :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ActiveCell.Parent.Cells.FormatConditions.Delete 'RAZ
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
End With
End Sub
 

Dranreb

XLDnaute Barbatruc
Bonsoir.
Une autre proposition :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Dim CelluleSurbrillance As Range, CouleurPropre As Long
   On Error Resume Next
   Set CelluleSurbrillance = Sh.[CelluleSurbrillance]
   If Err = 0 Then If CelluleSurbrillance.Interior.Color = &HFFA5& _
      Then CelluleSurbrillance.Interior.Color = Sh.[CouleurPropre]
   On Error GoTo 0
   Set CelluleSurbrillance = Target(1, 1)
   Sh.Names.Add "CelluleSurbrillance", CelluleSurbrillance
   Sh.Names.Add "CouleurPropre", CelluleSurbrillance.Interior.Color
   CelluleSurbrillance.Interior.Color = &HFFA5&
   End Sub
 

Bruno09

XLDnaute Nouveau
La macro précédente est à placer dans le code d'une feuille de calcul.

Si on veut l'appliquer à toutes les feuilles du classeur placer dans ThisWorkbook :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ActiveCell.Parent.Cells.FormatConditions.Delete 'RAZ
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
End With
End Sub
Bonjour Job75,
Ceci fonctionne mais je ne peux plus faire de copier coller maintenant. Est-ce que tu as une solution?
Merci,
 

Bruno09

XLDnaute Nouveau
Bonjour Job75,
J'ai un autre souci. Dans ma colonne O j'ai une formule qui calcule le nombre de caractère de la colonne D et si le nombre est plus grand que 40 j'ai une mise en forme conditionnel et la cellule devient jaune et le texte en rouge mais avec le code de surbrillance cela disparaît. J'ai beau essayé de rajouter une ligne au code mais je n'y arrive pas. Est-ce que tu peux encore une fois m'aider?
Merci d'avance!
 

job75

XLDnaute Barbatruc
Bonjour Bruno09, le forum,

Cette macro, toujours dans ThisWorkbook, crée les 2 MFC :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Application.CutCopyMode Then Exit Sub 'si copier/couper
Application.ScreenUpdating = False
Cells.FormatConditions.Delete 'RAZ
'---1ère MFC, en colonne O--
[O:O].FormatConditions.Add xlExpression, Formula1:="=--$O1>40"
With [O:O].FormatConditions(1)
    .Interior.Color = vbYellow 'fond jaune
    .Font.Color = vbRed 'police rouge
    .Font.Bold = True 'gras
End With
'---2ème MFC, sur la cellule active---
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
ActiveCell.FormatConditions(ActiveCell.FormatConditions.Count).SetFirstPriority
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
    .StopIfTrue = True
End With
End Sub
Edit : "=--$O1>40" est plus simple.

A+
 
Dernière édition:

Bruno09

XLDnaute Nouveau
Bonjour Bruno09, le forum,

Cette macro, toujours dans ThisWorkbook, crée les 2 MFC :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Application.CutCopyMode Then Exit Sub 'si copier/couper
Application.ScreenUpdating = False
Cells.FormatConditions.Delete 'RAZ
'---1ère MFC, en colonne O--
[O:O].FormatConditions.Add xlExpression, Formula1:="=N($O1)*($O1>40)"
With [O:O].FormatConditions(1)
    .Interior.Color = vbYellow 'fond jaune
    .Font.Color = vbRed 'police rouge
    .Font.Bold = True 'gras
End With
'---2ème MFC, sur la cellule active---
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
ActiveCell.FormatConditions(ActiveCell.FormatConditions.Count).SetFirstPriority
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
    .StopIfTrue = True
End With
End Sub
A+
Merci!
 

job75

XLDnaute Barbatruc
En fait avec cette macro qui nomme la cellule active on peut faire cohabiter autant de MFC que l'on veut :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Application.CutCopyMode Then Exit Sub 'si copier/couper
Dim fc As FormatCondition
'---supprime la MFC---
If TypeName([CA]) = "Range" Then
    For Each fc In [CA].FormatConditions
        If fc.Interior.Color = vbBlack Then fc.Delete
    Next
End If
'---crée la MFC---
ActiveCell.FormatConditions.Add xlExpression, Formula1:=1
ActiveCell.FormatConditions(ActiveCell.FormatConditions.Count).SetFirstPriority
With ActiveCell.FormatConditions(1)
    .Interior.Color = vbBlack 'fond noir
    .Font.Color = vbWhite 'police blanche
    .Font.Bold = True 'gras
    .StopIfTrue = True
End With
ActiveSheet.Names.Add "CA", ActiveCell 'nom défini DANS LA FEUILLE  pour mémoriser la cellule
End Sub
 
Dernière édition:

Discussions similaires

Réponses
3
Affichages
335

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla