XL 2019 Colorier une lettre, un mot ou une phrase recherchée

[cd95]

Bonjour,

Est-ce que quelqu’un peut m’aider à modifier le code que j’ai trouvé dans le fichier joint qui fait la recherche que pour des mots et moi je veux l’élargir pour rechercher soit une lettre ou un mot isolé comme le permet à ce moment ce code mais rajouter l’option de pouvoir rechercher une phrase entière que ce code ne fait pas. Et surtout traiter les recherche ligne par ligne, copier le résultat de chaque mot ou phrase recherchée dans un nouvel onglet.

Je m’explique mieux : Ce fichier recherche tous les mots de la colonne « A » à la fois moi je veux une procédure qui recherche le premier mot ou la première phrase, copier le résultat dans un nouvel onglet ensuite la procédure se dirige vers la deuxième recherche (ou deuxième ligne) et faire la même chose en série et si possible aussi de nommer chaque onglet par le numéro de la ligne (1 : pour la première ligne de recherche, 2 pour la deuxième ligne et ainsi de suite…).

J’espère que ce n’est pas trop demandé (En option : Onglet « BD » [comme base], onglet : [Liste des mots ou phrase recherchée] et onglet [résultat N°1, résultat N°2, résultat N°3 et ainsi de suite]).

N.B : Il faut rester dans le même thème c.a.d colorier la lettre, la phrase ou le mot entier recherché sans autant colorier les mêmes lettres qui composent ce mot mais qui sont attachés à une autre chaîne.

Exemple N°1 : si je cherche le mot « toto » dans la phrase : (toto veut manger des totomates mais toto est maladetoto). Le résultat doit donner : (toto veut manger des totomates mais toto est maladetoto)

Exemple N°2 : si je cherche la lettre « T » dans la phrase : (Théorème : Xn= T x P et Température = T : 1.35°). Le résultat doit donner : (Théorème : XL= T x P et Température= T : 1.35°).

 

[patricktoulon]

re
bon ben en fait on en perd un peu partout contrairement a ce que je pensais

1° inscription dans dico des property des cells de la liste
2° inscription na dans colonne 2
3° if/else imbriqué ou successifs dans "paslettre"

difficile de modifier le principe imbrique de lui même les étapes grrr!!

 

[mapomme]

Bonjour à tous,

Une v3a qui accélère l'écriture de la colonne B et qu'il faut prendre (j'avais oublié un préfixe point dans les précédentes) mais comme tu l'as analysé je reste plus lent.

 

[cd95]

Bonjour à tous,

Une v3a qui accélère l'écriture de la colonne B et qu'il faut prendre (j'avais oublié un préfixe point dans les précédentes) mais comme tu l'as analysé je reste plus lent.

Ah oui bien joué, avec cette solution vous avez réussi à diviser le temps en deux. Chapeau

 

[cd95]

Ah oui bien joué, avec cette solution vous avez réussi à diviser le temps en deux. Chapeau

Le temps a été réduit en fait car les nombres des mots recherchés ont été aussi réduites.

 

[cd95]

Le temps a été réduit en fait car les nombres des mots recherchés ont été aussi réduites.

Mais c vrais quand gagne un peu plus de temps que l'ancienne version.

 

[patricktoulon]

re
ben en fait c'est l'utilisation du dico et le passage par une fonction externe a la sub qui ralenti aussi
mine de rien

pour info j'ai testé et re testé et re testé ......
une boucle sur cells (EN LECTURE!!!) ne dure pas plus que la même chose avec une Variable tableau

une belle performance en tout cas pour les deux méthodes

par contre avec ma version j'ai un soucis que j'ai du mal a agencer dans la version mélange

c'est l'union des cells qui correspondent pas au critères pour les deleter ensuite

le message affiche les lignes a deleter mais c'est pas bon

Private Sub CommandButton2_Click()
    Dim i&, cel1 As Range, cel As Range, couleur&, phrase$, mot$, plage As Range, listemot As Range, t, x As Boolean, y As Boolean
    Dim nextcell As Range, assupprimer As Range
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:B")): .Clear: End With   'clear feuil3

    Intersect(Sheets(1).UsedRange, Sheets(1).Range("A:A")).Copy [A1]    'copy feuil1 to feuil3

    With ActiveSheet: Set plage = Intersect(.UsedRange, .Range("A:A")): End With
    Set assupprimer = plage.Cells(plage.Cells.Count, 1)
    Application.ScreenUpdating = False

    With Sheets("liste"): Set listemot = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)): End With
    t = Timer
    For Each cel1 In listemot.Cells
        mot = Trim(cel1.Value)
        For Each cel In plage.Cells
            If mot <> "" Then
                phrase = " " & cel.Value & " "
                For i = 2 To Len(phrase)
                    If Mid(phrase, i, Len(mot)) = mot Then
                        x = UCase(Mid(phrase, i - 1, 1)) = LCase(Mid(phrase, i - 1, 1)) And Not IsNumeric(Mid(phrase, i - 1, 1))
                        y = UCase(Mid(phrase, i + Len(mot), 1)) = LCase(Mid(phrase, i + Len(mot), 1)) And Not IsNumeric(Mid(phrase, i + Len(mot), 1))

                        If x And y Then
                            With cel.Characters(i - 1, Len(mot))
                                .Font.Color = cel1.Font.Color
                                .Font.Italic = cel1.Font.Italic
                                .Font.Bold = cel1.Font.Bold
                            End With

                        End If
                        i = i + Len(mot)
                    End If
                Next
            End If
            'cel.Offset(, 1) = IsNull(cel.Font.Color)
            If Not IsNull(cel.Font.Color) Then Set assupprimer = Union(assupprimer, cel)
        Next cel
    Next cel1
    MsgBox assupprimer.Address
    'assupprimer.EntireRow.Delete xlShiftUp
    MsgBox Format(Timer - t, "00.00 \sec") & vbCrLf

End Sub

je travaille dessus et reviens

 

[patricktoulon]

re
yes!!yes!!

voila je supprime les lignes qui restent noires a la fin sans utiliser de colonnes intermédiaires

Private Sub CommandButton2_Click()
    Dim i&, cel1 As Range, cel As Range, couleur&, phrase$, mot$, plage As Range, listemot As Range, t, x As Boolean, y As Boolean
    Dim nextcell As Range, assupprimer As Range, q, q2
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:B")): .Clear: End With   'clear feuil3

    Intersect(Sheets(1).UsedRange, Sheets(1).Range("A:A")).Copy [A1]    'copy feuil1 to feuil3

    With ActiveSheet: Set plage = Intersect(.UsedRange, .Range("A:A")): End With
    Set assupprimer = plage.Cells(plage.Cells.Count, 1)
    Application.ScreenUpdating = False

    With Sheets("liste"): Set listemot = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)): End With
    t = Timer
    q = listemot.Cells.Count
    For Each cel1 In listemot.Cells
        mot = Trim(cel1.Value)
        q2 = q2 + 1
           For Each cel In plage.Cells
                         If mot <> "" Then
                phrase = " " & cel.Value & " "
                For i = 2 To Len(phrase)
                    If Mid(phrase, i, Len(mot)) = mot Then
                        x = UCase(Mid(phrase, i - 1, 1)) = LCase(Mid(phrase, i - 1, 1)) And Not IsNumeric(Mid(phrase, i - 1, 1))
                        y = UCase(Mid(phrase, i + Len(mot), 1)) = LCase(Mid(phrase, i + Len(mot), 1)) And Not IsNumeric(Mid(phrase, i + Len(mot), 1))

                        If x And y Then
                            With cel.Characters(i - 1, Len(mot))
                                .Font.Color = cel1.Font.Color
                                .Font.Italic = cel1.Font.Italic
                                .Font.Bold = cel1.Font.Bold
                            End With

                        End If
                        i = i + Len(mot)
                    End If
                Next
            End If
             If Not IsNull(cel.Font.Color) And q2 = q Then Set assupprimer = Union(assupprimer, cel)
        Next cel
    Next cel1
    'MsgBox assupprimer.Address
    assupprimer.EntireRow.Delete xlShiftUp
    MsgBox Format(Timer - t, "00.00 \sec") & vbCrLf

End Sub

entre 0.48 et 0.61 avec deletage des lignes non colorée
le seul problème ça déforme mes boutons
edit:
j'ai résolu le problème en remplaçant les activX par des shapes que je peux verouiller pour les boutons
et transféré dans un module les codes
puré ça fuse


edit2:
je viens de tester avec la même série de mots que la v3
@mapomme 12.34
@patricktoulon 10.76

 

[mapomme]

Re @patricktoulon,

le seul problème ça déforme mes boutons

pour ne pas déformer les boutons, il faut leur attribuer la propriété suivante (valable pour toute shape aussi)

 

[patricktoulon]

re
@mapomme
oui mais les activX ca les déformes quand même

 

[patricktoulon]

re tenez j'ai rassemblé les 3 versions dans un seul fichier
1 like patricktoulon
2 melange methode mapomme /patricktoulon
3 mapomme V3a

vous pouvez tester les 3 versions simultanément

 

[mapomme]

oui mais les activX ca les déformes quand même

Peux-tu tester les suppressions de lignes ou colonnes ? Chez moi, la position et la taille sont conservées (du moins me semble-t-il).


nota: merci pour le fichier avec les trois méthodes.

 

[patricktoulon]

re
ligne :ca se fait quasiment invisiblement
colonne : ça recule a gauche et reviens en place

 

[mapomme]

Re @patricktoulon
Ok, Ok

 

[patricktoulon]

tu a testé le fichier compil ?

 

[cd95]

tu a testé le fichier compil ?

Message pour « mapomme » et « patricktoulon » : pourriez-vous me dire pour mon apprentissage qu’est-ce qu’il aura fallu rajouter au code de mon premier fichier joint pour qu’il accepte la recherche d’une phrase en entier en conservant le même code. Ou est-ce qu’il faut vraiment tous changer ? (J’ai passé du temps fou en vain)