XL 2019 mettre en rouge

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

  • rouge.xlsm
    19.7 KB · Affichages: 20
Trier par date Trier par votes
S

soan

XLDnaute Barbatruc
Inactif
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

  • rouge.xlsm
    18.2 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
534
halecs93
halecs93
G
  • Question
Microsoft 365 Transfert de données
Réponses
7
Affichages
345
GClaire
G
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
454
Phil69970
Phil69970
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
180
aziz
A
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
915
thivame
T
B
  • Question
Microsoft 365 Additionner des cellules même ligne en userform vba
Réponses
13
Affichages
335
sousou
sousou
Usine à gaz
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
306
Usine à gaz
Usine à gaz
M
  • Résolu(e)
XL 2016 Comparaison - Ignorer les accents
Réponses
8
Affichages
485
patricktoulon
patricktoulon
C
  • Question
XL 2019 Déplacer lignes selon contenu d'une cellule
Réponses
2
Affichages
765
ARMAEL
A
D
  • Question
XL 2016 VBA format date
2
Réponses
17
Affichages
819
vgendron
vgendron

Membres actuellement en ligne

5 membres et 78 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 177
Messages
2 085 972
Membres
103 073
dernier inscrit
MSCHOE16