XL 2019 mettre en rouge

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion bennp
  • 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 !

S'inscrire
B

bennp

XLDnaute Occasionnel
Bonjour,

j'ai effectué une macro mais je souhaiterais l'optimiser et la réduire mais je ne trouve pas comment, pouvez vous m'aider svp ?

VB: 
Sub ROUGE()
Dim i, j, k As Integer
Dim x As Variant
i = 127
Do
    i = i + 1
Loop Until Feuil1.Range("B" & i).Text = "GÉNÉRATEURS"
k = 4
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud"",RC[-11],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents

k = 10
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
k = 11
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
 k = 4
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud"",RC[-11],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents

k = 10
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
k = 11
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=5).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 '''
  Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud seul"",RC[-11],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents

k = 10
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
k = 11
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""chaud seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
 k = 4
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud seul"",RC[-11],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents

k = 10
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
k = 11
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
 k = 4
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud Seul"",RC[-11],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "Q").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents

k = 10
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud Seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
 
k = 11
 Feuil1.Range("AB" & i + k).FormulaR1C1 = "=IFERROR(FIND(""Chaud Seul"",RC[-19],1),"""")"
 x = Feuil1.Range("AB" & i + k).Value
    If Feuil1.Range("AB" & i + k) <> "" Then
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.FontStyle = "Gras"
       Feuil1.Cells(i + k, "I").Characters(Start:=x, Length:=10).Font.Color = RGB(192, 0, 0)
     End If
 Feuil1.Range("AB" & i + k).ClearContents
End Sub
 

Pièces jointes

Trier par date Trier par votes
Re Bonjour,
Si vous tenez vraiment à cette spécificité alors il n'y a que le VBA à ma connaissance.
Mais si vous acceptez que l'ensemble de la chaîne soit rouge alors une MFC pourrait simplifier les choses. 🙂
 
Vote positif 0 Vote négatif
Bonjour Ben, sylvanu,

Je propose cette petite optimisation :
VB: 
Option Explicit

Dim txt$, lig&

Private Sub Job(col%, dv&)
  Dim cel As Range, chn$, p%: Set cel = Feuil1.Cells(lig + dv, col)
  chn = cel.Value: p = InStr(1, chn, txt, 1): If p = 0 Then Exit Sub
  With cel.Characters(p, Len(chn)).Font
    .Bold = -1: .Color = RGB(192, 0, 0)
  End With
End Sub

Sub ROUGE()
  Const Q As Byte = 17, I As Byte = 9: lig = 127: Application.ScreenUpdating = 0
  Do: lig = lig + 1: Loop Until Feuil1.Cells(lig, 2).Text = "GÉNÉRATEURS"
  txt = "Chaud": Job Q, 4: Job I, 10: Job I, 11: txt = txt & " seul"
  Job Q, 4: Job Q, 11: Job I, 10: Job I, 11
End Sub
Ce code VBA ne se sert pas de la colonne AB ➯ dans ton fichier réel, tu peux la supprimer. 😉
Si tu passes mon code VBA dans la machine à laver, ça le rétrécira peut-être un peu plus ?

soan
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
334
Gestionnaire_rh
G
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
599
AtTheOne
AtTheOne
cathodique
  • Question Question
XL 2010 Comment lire array dans item dictionnaire
2 3
Réponses
33
Affichages
2 K
cathodique
cathodique
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
80
piga25
piga25
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
219
patricktoulon
patricktoulon
U
  • Question Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
375
Phil69970
Phil69970
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
250
CortoXls
C
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
C
  • Question Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
431
CathyLD
C
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
173
crocrocro
C
D
  • Question Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
1 K
AtTheOne
AtTheOne
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
405
Gégé-45550
Gégé-45550
A
  • Résolu(e)
Microsoft 365 VBA filtre erreur si pas la condition
Réponses
3
Affichages
74
Ang3lina
A
G
  • Question Question
Microsoft 365 Export données d'une listview
Réponses
5
Affichages
495
GClaire
G
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
584
Claudinedu13
C
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
1 K
halecs93
halecs93
G
  • Question Question
Microsoft 365 Transfert de données
Réponses
7
Affichages
722
GClaire
G
G
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
500
GClaire
G
D
  • Question Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
2 K
Dranreb
Dranreb
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
1 K
Phil69970
Phil69970
Retour