Microsoft 365 Code VBA pour cellule en surbrillance

  • Initiateur de la discussion Initiateur de la discussion Bruno09
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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 =...
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+
 
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
 
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
 
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,
 
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!
 
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:
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!
 
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:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
72
Affichages
1 K
Réponses
7
Affichages
123
Réponses
4
Affichages
141
Retour