Autres Mettre en rouge et en gras des années en format texte à l'intérieur de texte

[Chrige]

Bonjour à tous

Mettre en rouge des années, c’est facile avec une MFC
Mettre en rouge une partie de texte, en manuel c’est facile aussi
Mais comme j’ai plus d’une centaine de cas
Je me demande s’il serait possible de le faire en macros
Ou alors avec une fonction à l’intérieur d’une MFC

Dans l’exemple sont à mettre en rouge et en gras les années
- Ces années sont à l’intérieur de texte
- Le nombre de caractères est différent
- L’emplacement de l’année est différent
- Seul point commun, les seuls chiffres présents ne concernent que l’année et il n’y a qu’une seule année dans chaque cellule.
On peut dire donc qu'il y a toujours 4 chiffres ou aucun chiffre
-Toutes les années sont sur 4 chiffres et commencent donc toujours par 1 ou par 2

Cela à peut-être déjà été fait, mais je pas trouvé sur le Web ??

 

[job75]

Bonjour Chrige,

Exécutez cette macro ;

Sub Annee()
Dim c As Range, x$, i%
Application.ScreenUpdating = False
For Each c In [A1].CurrentRegion 'plage à adapter
    x = c
    For i = 1 To Len(x) - 3
        If Mid(x, i, 4) Like "####" Then
            With c.Characters(i, 4).Font
                .Color = vbRed
                .Bold = True 'gras
            End With
            Exit For
        End If
Next i, c
End Sub

PS : pas de s à parmi !!!

A+

 

[patricktoulon]

bonjour @job75 , @Chrige
perso avec ce contexte tel que présenté je procède par une boucle a sursaut
j'entend par là que boucler de 1 à len(valeur) peut être lourd sur X cellules
alors je boucle avec le x=instr (y,valeur," ")
x et y valant 1 au départ et y étant incrémenté avec y=x+1 pour passer après le caracteres " "
beaucoup plus rapide
en gros je boucle par mot sans utiliser de split

Sub redyear()
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        c = Cells(i, 1).Value
        y = 1
        Do
            x = InStr(y, c, " "): y = x + 1
            If x > 0 Then
                If Val(Trim(Mid(c, y, 5))) > 0 Then
                    With Cells(i, 1).Characters(Start:=x, Length:=5).Font
                        .Bold = True
                        .Color = vbRed
                    End With
                 End If
            End If
        Loop Until x = 0
    Next
End Sub

 

[patricktoulon]

re
ça m’étonne que @mapomme ne soit pas intervenu sur ce coup là

 

[job75]

Salut patricktoulon,

Autre solution avec une seule boucle :

Sub Annee()
Dim c As Range, x$, i%
Application.ScreenUpdating = False
For Each c In [A1].CurrentRegion 'plage à adapter
    x = c
    i = InStr(x, 1)
    If i = 0 Then i = InStr(x, 2)
    If i Then
        With c.Characters(i, 4).Font
            .Color = vbRed
            .Bold = True 'gras
        End With
    End If
Next
End Sub

Pour tester j'ai recopié le tableau A1:A23 sur 23 000 lignes, chez moi :

- macro du post #2 => 2,2 secondes

- macro du post #3 => 2,1 secondes (en ajoutant Application.ScreenUpdating = False)

- macro de ce post #5 => 2,1 secondes.

La différence n'est pas significative, je préfère celle du post #2.

A+

 

[patricktoulon]

re
@job75
oui mais tu traite 1 seule occurrence en mono boucle on sait jamais peut être en aura t il plusieurs
je vais tester moi aussi

 

[mapomme]

Supprimé pas vu qu'il pouvait y avoir des parenthèses

 

[patricktoulon]

bonjour @mapomme
et ben dis donc t'en a mis un temps à venir
souvenir souvenir
bon faut pas tomber en l'an 700 after JC MAIS bon on dira rien hein

 

[mapomme]

et ben dis donc t'en a mis un temps à venir

Et maintenant vite m'en vais sortir avant le couve-feu.

 

[job75]

Bonjour mapomme,

Oui en ajoutant un espace c'est un peu plus rapide => 1,9 seconde sur 23 000 lignes.

Mais alors les années entre parenthèses (en A8 et A26) ne sont pas traitées !

Donc normal que ce soit un peu plus rapide.

A+

 

[mapomme]

Mais alors les années entre parenthèses (en A8 et A26) ne sont pas traitées !

J'avais point vu les parenthèses

 

[patricktoulon]

test avec sub anne pour 11000 lignes
2.3XXXXX
test avec redyear pour 11000 lignes
1.8XXXXXx
les deux sans le blocage du screenupdating

et étonnamment avec le blocage du screenupdating c'est la tienne qui est plus rapide
il faudra m'expliquer le shmilblik là
si on peu plus se fier a la logique je sais plus moi

 

[Chrige]

Bonjour Job75, Mapomme, Patricktoulon
Du 1er coup !

J'ai pas bien compris la macro
Je suppose que "####" permet de reconnaitre des chiffres ?
Mais cela fonctionne parfaitement
Merci à nouveau Job

Merci aussi Mapomme et Patricktoulon pour vos macros
Je n'ai qu'une centaine de ligne, je ne suis donc pas très préoccupé par le temps de traitement
Mais c'est vrai que la macro de Job, à défaut de la comprendre parfaitement, parait plus simple

 

[patricktoulon]

re
@job75
ajoute le sursaut de 4 pour le non like tu gagne un peu je tombe a 1.8 et sans le sreenupdating 0.8XXXX POUR 11000 lignes

Sub Annee() '@job75 (1)
Dim c As Range, x$, i%
tim = Timer
  For Each c In [A1].CurrentRegion 'plage à adapter
    x = c
    For i = 1 To Len(x) - 3
        If Mid(x, i, 4) Like "####" Then
            With c.Characters(i, 4).Font
                .Color = vbRed
                .Bold = True 'gras
            End With
            Exit For
        Else: i = i + 4  'REBONDi APRES LA CHAÎNÉ DÉJÀ TESTÉE!!!!!
        End If
Next i, c
MsgBox Timer - tim
End Sub

 

[job75]

ajoute le sursaut de 4 pour le non like tu gagne un peu

Cela revient à faire une boucle avec un Step de 4 donc ça ne va pas du tout, tu n'as pas testé.