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

2 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
garnote
Joli tu dis ;-))) Super astucieux et moins compliqué
que la formule proposée par JW :
=(SOMME(NBCAR(C5))-NBCAR(SUBSTITUE(C5;"a";"")))/NBCAR("a")
à valider matriciellement.

Serge


"" a écrit dans le message de news:

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


















Avatar
garnote
Ou bien :
=NBCAR(C5)-NBCAR(SUBSTITUE(C5;"a";""))
Viens de comprendre que la formule de JW permettait
de compter le nombre de fois ou apparaît une suite
de caractères.
{=(SOMME(NBCAR(C5))-NBCAR(SUBSTITUE(C5;"ex";"")))/NBCAR("ex")}

Serge


"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