Autres Mise en surbrillance, un mot dans un texte

[VIARD]

Bonjours à toutes et tous

Cadeau de nouvel an, pour changer un peu des tableaux.
Mettre un mot en valeur dans un texte, poème poésie ou autres
Surbrillance de rimes de type AABB etc.
Tout se trouve expliqué dans l'user.
Si cela peut-être utile.
Bonne année à tous de santé
Amicalement

Jean-Paul

 

[patricktoulon]

re

 

[Lolote83]

Bonjour,
@VIARD , merci pour le

Toutefois j'aime bien le code de Lolote, plus simple, j'ai juste ajouté le nombre de mot.

Cependant, pourquoi ne pas utiliser le code de @patricktoulon (que je salue au passage) car plus rapide, mieux défini, et prenant en compte plus de paramètres.
Comme je l'ai dit au post#5, la version donnée a été faite à la va vite et sans vraiment de contrôle (nombre de lignes, lignes vides ou non, mot entier ou non ........)
Bref, si tu veux quelque chose de compétitif, rapproche toi plus du code de Patrick que du mien.
@+ Lolote83

 

[patricktoulon]

Bonjour lolote83
en terme de mécanique dans le tiens il manque pas beaucoup en fait tout en laissant ta boucle len

 

[patricktoulon]

regarde
ton code

Sub Surbrillance2()
   Dim tim#
   tim = TIMER
   Application.ScreenUpdating = False
    With Sheets("Feuil1")
        With Range("M1:M5000")
            .Font.Color = RGB(0, 0, 0)
            .Font.Bold = False
        End With
        xTexteRouge = .[ND_Cherche]
        xLgrTexte = Len(xTexteRouge)
        For Each XceLL In Range("M1:M5000")
            For f = 1 To Len(XceLL)
               'Debug.Print "recherche dans " & XceLL.Address & " du caractère  " & f & " au caractère " & f + Len(xTexteRouge)
                          xSelectionTexte = Mid(XceLL, f, xLgrTexte)
                If UCase(xSelectionTexte) = UCase(xTexteRouge) Then
                    With XceLL.Characters(Start:=f, Length:=xLgrTexte).Font
                        .ColorIndex = 3
                        .Bold = True
                    End With
                End If
            Next f
        Next XceLL
    [c5] = Format((TIMER - tim), "0#.000 ""Seconde(s)"" ")
 
  End With
    Application.ScreenUpdating = True
End Sub

a nouveau ton code avec 2 lignes en plus et 2 ligne en moins
les deux lignes en plus sont pointé par "!!!"
les deux lignes en moins c'est la condition if ucase (mis en commentaire )puisque je passe par un instr vbtextcompare

Sub Surbrillance2lolottebis()
   Dim tim#
   tim = TIMER
   Application.ScreenUpdating = False
    With Sheets("Feuil1")
        With Range("M1:M5000")
            .Font.Color = RGB(0, 0, 0)
            .Font.Bold = False
        End With
        xTexteRouge = .[ND_Cherche]
        xLgrTexte = Len(xTexteRouge)
        For Each XceLL In Range("M1:M5000")
            For f = 1 To Len(XceLL)
              f = InStr(f, XceLL.Value, xTexteRouge, vbTextCompare)''!!!!!!!!!!!!!!
              If f = 0 Then Exit For'!!!!!!!!!!!!!!!!!!!!!!!!!!
              'Debug.Print "recherche dans " & XceLL.Address & " du caractère  " & f & " au caractère " & f + Len(xTexteRouge)
                          xSelectionTexte = Mid(XceLL, f, xLgrTexte)
                'If UCase(xSelectionTexte) = UCase(xTexteRouge) Then
                    With XceLL.Characters(Start:=f, Length:=xLgrTexte).Font
                        .ColorIndex = 3
                        .Bold = True
                    End With
                'End If
            Next f
        Next XceLL
    [c5] = Format((TIMER - tim), "0#.000 ""Seconde(s)"" ")
 
  End With
    Application.ScreenUpdating = True
End Sub

teste les deux tu verra (jour/nuit)

 

[VIARD]

Bonjour lolotte, Patrick et à tous

Bon j’ai refait des manips en réactualisant mon code.
Et simplification proposé par Patrick, j’ai ajouté mot entier ou pas.
De même le texte est étendu à 5000 lignes pour comparaison.

JPV	5000 lignes	2,656 seconde(s)​	la​	553 mots	tous les "la"
patrick	5000 lignes	0,438 seconde(s)	la​	553 mots	tous les "la"
Jpv	5000 lignes	1,844 seconde(s)	la​	276 mots	"la" isolé
patrick	5000 lignes	0,391 seconde(s)​	la​	276 mots	"la" isolé
JPV	5000 lignes	4,234 seconde(s)​	à​	827 mots	tous les "à"
JPV	5000 lignes	2,296 seconde(s)​	à​	364 mots	"à" isolé
Patrick	5000 lignes	0,500 seconde(s)​	à​	827 mots	tous les "à"
patrick	5000 lignes	0,391 seconde(s)​	à​	364 mots	"à" isolé
JPV	5000 lignes	20,449 seconde(s)​	a​	12663 mots	tous les "a"
JPV	5000 lignes	1,187 seconde(s)​	a​	1 mot	"a" isolé
Patrick	5000 lignes	3,039 seconde(s)​	a​	12663 mots	tous les "a"
Patrick	5000 lignes	0,328 seconde(s)​	a​	1 mot	"a" isolé

1 - On voit de suite le module de Patrick est plus rapide, y a pas photo.
Toutefois, je ne m’estime pas trop mauvais.
Le comptage me fait perdre 300 millièmes de seconde pour un mot entier.

2 - Par contre, a propos de la surbrillance du texte avant les deux points

Ma version​
5004​	Nb Lignes
5 ' 55 '' 636 mil​	Deux points
355,637 S(s)​	For (boucle)

Bon là c’est long, du coup j’ai repris le code en adaptent celui de Patrick :

Version modifiée Patrick​
5004​	Nb Lignes
0 ' 0 '' 921 mil​	Deux points
00,922 S(s)​	For (Do)

2302 ( : ) 2 points

Le résultat parle de lui-même



3 – Pour les rîmes pas de soucis, type AABB
Bouton Rîmes

JPV

5000 lignes

3,422 seconde(s)​

En vous remerciant Lolote, Patrick pour l’échange.
Cordialement

Jean-Paul

 

[VIARD]

Désolé le code n'est pas passé

'====================
Sub Surbrillance_avant_deux_points()
'patricktoulon
Dim TxT$, XceLL, X&, Tim#, V&, Nb&
Dim Dif#, DG%, Dec#, M&, S&

Tim = Timer
Application.ScreenUpdating = False
Nb = Cells(Rows.Count, 13).End(xlUp).Row
Label9.Caption = Nb: V = 0
With Sheets("Feuil1")
    With Feuil1.Range("M1:M5010")
        .Font.Color = RGB(0, 0, 0)
        .Font.Bold = False
    End With
    TxT = ":"
    If TxT = "" Then Exit Sub
    For Each XceLL In Feuil1.Range("M1:M5010").Cells
        With XceLL
            If XceLL <> "" Then
                X = 1
'-------------------------------
                Do
                    X = InStr(X, UCase(.Text), UCase(TxT))
                    If X > 0 Then
                       With .Characters(Start:=1, Length:=X).Font
                            .ColorIndex = 5
                            .Bold = True
                            .Italic = True
                        End With
                        V = V + 1
                        X = X + Len(TxT)
                    End If
                Loop While X > 0
'-------------------------------
            End If
        End With
    Next XceLL
End With
Label3.Caption = V
'-------- mesure durée --------
Dif = Timer - Tim
DG = 3 'Nombre de digit décimale
'------ Récup Décimale --------
Dec = Dif - Fix(Dif)
Dec = Mid(Dec, 3, DG) 'récup unique décimale
'------------------------------
M = Fix((Dif Mod 3600) / 60)
S = Int(Dif) Mod 60
Label7.Caption = Format(M, "#0" & " ' ") & Format(S, "#0" & " '' ") & Dec & " mil"
'------------------------------
Label6.Caption = Format((Timer - Tim), "0#.000 ""S(s)"" ")
Application.ScreenUpdating = True
End Sub
'=========================

 

[VIARD]

Cette fois si c'est complet

 

[patricktoulon]

re
Bonjour @VIARD
et ben dis donc
perso pour les rimes j'avais détecté des trucs mais bon
et je suis sur que je peux spider encore plus
alors oui en effet plus il y a d’occurrences plus le temps est long forcement
de plus de mettre en rouge, en bold,et size ajoute du temps
si l'on se contente de mettre en rouge ça accélère la chose
du coup je suis allé le repêcher dans mes archives (te voyant pas revenir)

et il y a une autre méthode (sorti de mes bidouilles ) qui n'est pas piqué des verts et qui est 2 fois plus rapide
dans une discussion avec @mapomme datant de 3 ou 4 ans ,on devrait pouvoir la retrouver

 

[VIARD]

Bonjour Patrick et à tous

Oui, je suis revenu, je suis toujours occupé par tel ou tel chose.
D'accord avec toi. Pour les rimes j'ai pris le cas le plus simple. Après ça devient compliqué.
De plus dans la manip j'ai veillé à conserver les caractères spéciaux, bien sûr serait plus simple sans
mais dans ce cas le texte perd de son attrait..
Salutation
Jean-Paul