Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Raccourcir une macro

Raccourcir une macro

12 réponses
Avatar
garnote
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
Denis Michon
Bonjour Garnote,


Voici une procédure ...elle n'est pas plus courte... mais sûrement plus rapide...!


'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de news:zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge
Avatar
j
sans macro
sélectionne ta plage
si la cellule active est b8 :
format / mise en forme conditionnelle / la formule est
=ESTNUM(TROUVE("a";B8))
format / motif / rouge / ok / ok

--

http://jacxl.free.fr/



"garnote" a écrit dans le message de news:
zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge






Avatar
Denis Michon
Pour tenir compte de tes 2 conditions (que je n'avais pa vu ...;-) )

Respect de la casse et du nombre de "a" dans la cellule égale à 1:

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "a" 'sensible à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25").SpecialCells _
(xlCellTypeConstants, xlTextValues)
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, _
Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Len(C) - Len(Application. _
Substitute(C, Lettre, "")) = 1 Then
If R Is Nothing Then
Set R = C
Else
Set R = Union(R, C)
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And _
C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'--------------------------------------


Salutations!






Voici une procédure ...elle n'est pas plus courte... mais sûrement plus rapide...!


'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de news:zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge
Avatar
garnote
Dans une sélection de 100 000 cellules contenant
le texte "Excelabo", ta première version prenait 1m 20s
et ta deuxième prend 1m 55s
Quant à ma propre mienne, après avoir ajouté
Application.ScreenUpdating = False, elle prend 2m 29s.
Et la formule conditionnelle de jc ne fonctionne pas ;-(
Je vais tenter de trouver une formule conditionnelle qui
ferait le boulot !

Serge


"Denis Michon" a écrit dans le message de news:
YtQtb.34687$

Pour tenir compte de tes 2 conditions (que je n'avais pa vu ...;-) )

Respect de la casse et du nombre de "a" dans la cellule égale à 1:

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "a" 'sensible à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25").SpecialCells _
(xlCellTypeConstants, xlTextValues)
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, _
Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Len(C) - Len(Application. _
Substitute(C, Lettre, "")) = 1 Then
If R Is Nothing Then
Set R = C
Else
Set R = Union(R, C)
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And _
C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'--------------------------------------


Salutations!






Voici une procédure ...elle n'est pas plus courte... mais sûrement plus
rapide...!



'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de
news:zTOtb.34365$

Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge








Avatar
j
marche pas, marche pas, marche très bien sur mon vieux xl97
bon d'accord j'avais pas vu qu'il fallait un a et un seul


"" a écrit dans le message de news:
#
sans macro
sélectionne ta plage
si la cellule active est b8 :
format / mise en forme conditionnelle / la formule est
=ESTNUM(TROUVE("a";B8))
format / motif / rouge / ok / ok

--

http://jacxl.free.fr/



"garnote" a écrit dans le message de news:
zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge










Avatar
j
et celle là (cellule act en b10)
=ESTNUM((TROUVE("a";B10)))*ESTERR(TROUVE("a";DROITE(B10;NBCAR(B10)-(TROUVE("
a";B10)))))
(y a surement + simple...)


"" a écrit dans le message de news:
#
sans macro
sélectionne ta plage
si la cellule active est b8 :
format / mise en forme conditionnelle / la formule est
=ESTNUM(TROUVE("a";B8))
format / motif / rouge / ok / ok

--

http://jacxl.free.fr/



"garnote" a écrit dans le message de news:
zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge










Avatar
garnote
Et c'est là que mes bas me blessent ;-)))
Comment compter le nombre de a dans une cellule
en utilisant une formule ?

Serge


"" a écrit dans le message de news:

marche pas, marche pas, marche très bien sur mon vieux xl97
bon d'accord j'avais pas vu qu'il fallait un a et un seul


"" a écrit dans le message de news:
#
sans macro
sélectionne ta plage
si la cellule active est b8 :
format / mise en forme conditionnelle / la formule est
=ESTNUM(TROUVE("a";B8))
format / motif / rouge / ok / ok

--

http://jacxl.free.fr/



"garnote" a écrit dans le message de news:
zTOtb.34365$
Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge














Avatar
Denis Michon
Bonjour Garnote,

Avec ceci , je descends sous la minute (environ 52 secondes) sur un vieux PII-400)
Pour 100 000 cellules.

Toujours en respectant la casse de la lettre et du nombre limité à une occurrence par cellule.

Une mise en forme conditionnelle sur une plage aussi grande n'est pas évidente !!! et cela risque d'augmenter
sensiblement le temps de calcul de la feuille.

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, Tblo As Variant, G As Range
Dim Lettre As String

Dim D As Double, F As Double
D = Timer

Lettre = "a"
With Worksheets("Feuil1")
Set Rg = .Range("A1:E20000")
Tblo = Rg
For a = LBound(Tblo, 1) To UBound(Tblo, 1)
For b = LBound(Tblo, 2) To UBound(Tblo, 2)
If Len(Tblo(a, b)) - Len(Application. _
Substitute(Tblo(a, b), Lettre, "")) = 1 Then
If G Is Nothing Then
Set G = Cells(a, b)
Else
Set G = Union(G, .Cells(a, b))
End If
End If
Next
Next
G.Interior.ColorIndex = 3
End With
Set G = Nothing: Set Rg = Nothing

F = Timer
MsgBox F - D

End Sub
'--------------------------------------


Salutations!



"garnote" a écrit dans le message de news:8PQtb.34756$
Dans une sélection de 100 000 cellules contenant
le texte "Excelabo", ta première version prenait 1m 20s
et ta deuxième prend 1m 55s
Quant à ma propre mienne, après avoir ajouté
Application.ScreenUpdating = False, elle prend 2m 29s.
Et la formule conditionnelle de jc ne fonctionne pas ;-(
Je vais tenter de trouver une formule conditionnelle qui
ferait le boulot !

Serge


"Denis Michon" a écrit dans le message de news:
YtQtb.34687$

Pour tenir compte de tes 2 conditions (que je n'avais pa vu ...;-) )

Respect de la casse et du nombre de "a" dans la cellule égale à 1:

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "a" 'sensible à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25").SpecialCells _
(xlCellTypeConstants, xlTextValues)
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, _
Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Len(C) - Len(Application. _
Substitute(C, Lettre, "")) = 1 Then
If R Is Nothing Then
Set R = C
Else
Set R = Union(R, C)
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And _
C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'--------------------------------------


Salutations!






Voici une procédure ...elle n'est pas plus courte... mais sûrement plus
rapide...!



'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de
news:zTOtb.34365$

Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge








Avatar
Denis Michon
Et si tu tiens à une mise en forme conditionnelle :

=NBCAR(C5)-NBCAR(SUBSTITUE(C5;"a";""))=1


Salutations!



"Denis Michon" a écrit dans le message de news:ceRtb.34830$
Bonjour Garnote,

Avec ceci , je descends sous la minute (environ 52 secondes) sur un vieux PII-400)
Pour 100 000 cellules.

Toujours en respectant la casse de la lettre et du nombre limité à une occurrence par cellule.

Une mise en forme conditionnelle sur une plage aussi grande n'est pas évidente !!! et cela risque d'augmenter
sensiblement le temps de calcul de la feuille.

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, Tblo As Variant, G As Range
Dim Lettre As String

Dim D As Double, F As Double
D = Timer

Lettre = "a"
With Worksheets("Feuil1")
Set Rg = .Range("A1:E20000")
Tblo = Rg
For a = LBound(Tblo, 1) To UBound(Tblo, 1)
For b = LBound(Tblo, 2) To UBound(Tblo, 2)
If Len(Tblo(a, b)) - Len(Application. _
Substitute(Tblo(a, b), Lettre, "")) = 1 Then
If G Is Nothing Then
Set G = Cells(a, b)
Else
Set G = Union(G, .Cells(a, b))
End If
End If
Next
Next
G.Interior.ColorIndex = 3
End With
Set G = Nothing: Set Rg = Nothing

F = Timer
MsgBox F - D

End Sub
'--------------------------------------


Salutations!



"garnote" a écrit dans le message de news:8PQtb.34756$
Dans une sélection de 100 000 cellules contenant
le texte "Excelabo", ta première version prenait 1m 20s
et ta deuxième prend 1m 55s
Quant à ma propre mienne, après avoir ajouté
Application.ScreenUpdating = False, elle prend 2m 29s.
Et la formule conditionnelle de jc ne fonctionne pas ;-(
Je vais tenter de trouver une formule conditionnelle qui
ferait le boulot !

Serge


"Denis Michon" a écrit dans le message de news:
YtQtb.34687$

Pour tenir compte de tes 2 conditions (que je n'avais pa vu ...;-) )

Respect de la casse et du nombre de "a" dans la cellule égale à 1:

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "a" 'sensible à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25").SpecialCells _
(xlCellTypeConstants, xlTextValues)
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, _
Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Len(C) - Len(Application. _
Substitute(C, Lettre, "")) = 1 Then
If R Is Nothing Then
Set R = C
Else
Set R = Union(R, C)
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And _
C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'--------------------------------------


Salutations!






Voici une procédure ...elle n'est pas plus courte... mais sûrement plus
rapide...!



'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de
news:zTOtb.34365$

Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge








Avatar
j
joli...

"Denis Michon" a écrit dans le message de news:
liRtb.34841$
Et si tu tiens à une mise en forme conditionnelle :

=NBCAR(C5)-NBCAR(SUBSTITUE(C5;"a";""))=1


Salutations!



"Denis Michon" a écrit dans le message de
news:ceRtb.34830$

Bonjour Garnote,

Avec ceci , je descends sous la minute (environ 52 secondes) sur un vieux
PII-400)

Pour 100 000 cellules.

Toujours en respectant la casse de la lettre et du nombre limité à une
occurrence par cellule.


Une mise en forme conditionnelle sur une plage aussi grande n'est pas
évidente !!! et cela risque d'augmenter

sensiblement le temps de calcul de la feuille.

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, Tblo As Variant, G As Range
Dim Lettre As String

Dim D As Double, F As Double
D = Timer

Lettre = "a"
With Worksheets("Feuil1")
Set Rg = .Range("A1:E20000")
Tblo = Rg
For a = LBound(Tblo, 1) To UBound(Tblo, 1)
For b = LBound(Tblo, 2) To UBound(Tblo, 2)
If Len(Tblo(a, b)) - Len(Application. _
Substitute(Tblo(a, b), Lettre, "")) = 1 Then
If G Is Nothing Then
Set G = Cells(a, b)
Else
Set G = Union(G, .Cells(a, b))
End If
End If
Next
Next
G.Interior.ColorIndex = 3
End With
Set G = Nothing: Set Rg = Nothing

F = Timer
MsgBox F - D

End Sub
'--------------------------------------


Salutations!



"garnote" a écrit dans le message de
news:8PQtb.34756$

Dans une sélection de 100 000 cellules contenant
le texte "Excelabo", ta première version prenait 1m 20s
et ta deuxième prend 1m 55s
Quant à ma propre mienne, après avoir ajouté
Application.ScreenUpdating = False, elle prend 2m 29s.
Et la formule conditionnelle de jc ne fonctionne pas ;-(
Je vais tenter de trouver une formule conditionnelle qui
ferait le boulot !

Serge


"Denis Michon" a écrit dans le message de news:
YtQtb.34687$

Pour tenir compte de tes 2 conditions (que je n'avais pa vu ...;-) )

Respect de la casse et du nombre de "a" dans la cellule égale à 1:

'--------------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "a" 'sensible à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25").SpecialCells _
(xlCellTypeConstants, xlTextValues)
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, _
Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Len(C) - Len(Application. _
Substitute(C, Lettre, "")) = 1 Then
If R Is Nothing Then
Set R = C
Else
Set R = Union(R, C)
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And _
C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'--------------------------------------


Salutations!






Voici une procédure ...elle n'est pas plus courte... mais sûrement plus
rapide...!



'-------------------------------
Sub MettreDeLaCouleur()

Dim Rg As Range, C As Range
Dim R As Range, Lettre As String

'à définir
Lettre = "A" 'sans égard à la casse

With Worksheets(1)
Set Rg = .Range("a1:G25")
With Rg
Set C = .Find(Lettre, LookIn:=xlValues, Lookat:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Set R = C
Do
Set R = Union(R, C)
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
R.Interior.ColorIndex = 3
End If
End With
End With
Set Rg = Nothing: Set C = Nothing: Set R = Nothing
End Sub
'-------------------------------


Salutations!


"garnote" a écrit dans le message de
news:zTOtb.34365$

Bonsoir les fines mouches que vous êtes,

Comment colorier en rouge les cellules d'une sélection
qui contiennent un seul petit a ?
J'ai ceci :

Sub Cellule_Rouge_Si_Un_Seul_Petit_a_Dedans()
For Each c In Selection
For i = 1 To Len(c)
If Mid(c, i, 1) = "a" Then somme = somme + 1
Next i
If somme = 1 Then c.Interior.ColorIndex = 3
somme = 0
Next
End Sub

mais y aurait-il quelque chose de plus court ?

;-)

Serge














1 2