XL 2019 mettre en rouge

bennp · 28 Août 2020

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

sylvanu · 28 Août 2020

Bonjour Bennp,
Pourquoi ne pas utiliser de MFC au lieu d'un module VBA ?

bennp · 28 Août 2020

Je ne pense pas que l'on puisse juste mettre un mot en couleur dans une cellule sans mettre les autres, si ?

sylvanu · 28 Août 2020

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.

bennp · 28 Août 2020

ok, quelqu'un aurait une idée ?

soan · 28 Août 2020

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

bennp · 11 Septembre 2020

Bonjour, merci pour ta réponse je vais tester ca

XL 2019 mettre en rouge

bennp

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

bennp

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

bennp

XLDnaute Occasionnel

soan

XLDnaute Barbatruc

Pièces jointes

bennp

XLDnaute Occasionnel

Discussions similaires