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°).

 

[cd95]

Bonjour à @cd95 , @patricktoulon ,

Une autre façon. le code est dans module1.

Au début de module1, vous avez une constante que vous pouvez modifier suivant que vous voulez ou non distinguer les majuscules des minuscules.

Const CassIndiff = True   'True si on ne distingue pas les majuscules des minuscules

En fait j’ai des classeurs volumineux avec des onglets « BD » de 5000 lignes voir des fois plus et ça m’embête de devoir chaque fois rechercher un mot ou deux, supprimer les lignes sans couleurs et recopier toutes les lignes de nouveau pour une autre recherche.

 

[patricktoulon]

re
il s'agirait maintenant de mettre les mains dans le cambuie un peu !!!!!!!!
ta nouvelle demande est de niveau débutant
on va pas tout te faire

 

[cd95]

re
il s'agirait maintenant de mettre les mains dans le cambuie un peu !!!!!!!!
ta nouvelle demande est de niveau débutant
on va pas tout te faire

Je comprends. Je suis débutant et j'arrive des fois à bidouiller les codes mais j'avoue avec beaucoup du mal et rien à dire je n'ai pas vos expériences. Un grand MERCI à vous tous

 

[mapomme]

Re @cd95,

La version v2 qui affiche les résultats sur la feuille "Result" et qui supprime les cellules dont aucun texte n'est colorié.



Nota: préférez de loin la v3a qui est ICI.

 

[cd95]

Re @cd95,

La version v2 qui affiche les résultats sur la feuille "Result" et qui supprime les cellules dont aucun texte n'est colorié.

Ton code c’est tout ce que je voulais et ça m’a été d'un grand secours pour gagner du temps.
Je vous suis très reconnaissant. Vraiment merci beaucoup et bonne nuit.

 

[patricktoulon]

re
bonjour
hola la!!!! la!!!
@mapomme tu a oublié les nombres

"0t" ressort "0t"

et oui le test ucase lcase n'a aucune portée pour les chiffres

Function paslettres(texte, mot, debut&) As Boolean
Dim c$, ok1 As Boolean, ok2 As Boolean
   If debut = 1 Then
      ok1 = True
   Else
      c = Mid(texte, debut - 1, 1)
      ok1 = LCase(c) = UCase(c) And Not IsNumeric(c)
   End If
   If debut + Len(mot) > Len(texte) Then
      ok2 = True
   Else
      c = Mid(texte, debut + Len(mot), 1)
      ok2 = LCase(c) = UCase(c) And Not IsNumeric(c)
   End If
   paslettres = ok1 And ok2
End Function

je viens de tester en bloquant le tri et la suppression de ligne avec la recherche des 2 expressions

pour le même travail avec 1300 lignes et les deux avec transfert sur feuille 3

ton modele

mon modele avec like

 

[mapomme]

Bonjour @patricktoulon

hola la!!!! la!!!
@mapomme tu a oublié les nombres

Tu ne dors jamais ? Ou bien, tu penses en dormant ?
Les chiffres, je les avais zappés. Est ce que les chiffres sont des lettres ? . On va dire que oui.
Je m'en va adapter en NiLettreNiChiffre()...
En tout cas, merci pour ta judicieuse remarque.

 

[patricktoulon]

de rien
non ce matin debout a 5 heures un peu de soucis avec ce virus ,il me bloque dans mon travail et me fait des journées sèches qui me coûtent cher, j'ai 90% d'annulation ça fait mal au C....
alors je m'occupe l'esprit

espérons que cd95 repasse par là car je crois qu'il a choisi la tienne

en tout cas il y a eu 3/4 discussions similaires ces jours ci
et donc voila deux versions au points

 

[mapomme]

Bonjour @cd95 ,

@patricktoulon m'a signalé une anomalie dans ma v2 qui est corrigée dans la v3a ci-jointe.
Tu disposes donc de deux méthodes dont l'une est plus rapide (c'est celle de @patricktoulon )

 

[patricktoulon]

re et ben non il y a plus rapide a ma grande surprise

tu prend un bol un peu de @mapomme (principe (true true) de ta sub pas lettre )
a savoir le controle ucase lcase du caractère précédent et suivant ainsi que le test numérique
et le principe boucle len avec jumping de ma version



avant
la tienne avec une phrase et une lettre 1.89
la mienne avec une phrase et une lettre 0.64
le mélange des deux 0.45
j'ai testé avec fermeture du fichier a chaque fois sinon le timer est faussé (effet mémoire bien connu pour timer)

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
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A")):        .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
   
    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
                    End If
                Next
            End If
        Next cel
    Next cel1

    MsgBox Format(Timer - t, "00.00 \sec")

End Sub

met un autre bouton dans ta feuil3 et test

 

[cd95]

Bonjour @cd95 ,

@patricktoulon m'a signalé une anomalie dans ma v2 qui est corrigée dans la v3 ci-jointe.
Tu disposes donc de deux méthodes dont l'une est plus rapide (c'est celle de @patricktoulon )

Bonjour,

Je voulais juste vous remercier vous et remercier aussi notre ami « patricktoulon » pour le service que vous m’avez rendu hier et qui continue ce matin.
Heureusement qu’il y a des gens comme vous dans ces forums.

À charge de revanche ! Encore Merci.

 

[cd95]

re et ben non il y a plus rapide a ma grande surprise

tu prend un bol un peu de @mapomme (principe (true true) de ta sub pas lettre )
a savoir le controle ucase lcase du caractère précédent et suivant ainsi que le test numérique
et le principe boucle len avec jumping de ma version



avant
la tienne avec une phrase et une lettre 1.89
la mienne avec une phrase et une lettre 0.64
le mélange des deux 0.45
j'ai testé avec fermeture du fichier a chaque fois sinon le timer est faussé (effet mémoire bien connu pour timer)

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
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A")):        .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
  
    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
                    End If
                Next
            End If
        Next cel
    Next cel1

    MsgBox Format(Timer - t, "00.00 \sec")

End Sub

met un autre bouton dans ta feuil3 et test

Bonjour,
Merci à vous deux vous êtes vraiment ingénieux les deux et c’est vrai qu’avec votre nouveau code on gagne 0.03 secondes.

 

[patricktoulon]

re
mille excuses j'avais oublié de remettre le jumping du coup c'est encore plus rapide
i = i + Len(mot)
0.32 sec sur 1300 lignes

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
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A")):        .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
   
    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
        Next cel
    Next cel1

    MsgBox Format(Timer - t, "00.00 \sec")

End Sub

je vais maintenant m'attarder sur le modèle de @mapomme et découvrir pourquoi le temps est plus long (j'ai deja ma petite idée mais je vais vérifier d'abords

 

[mapomme]

Bonjour à tous,

Ben ça, c'est ti pas du beau télétravail collaboratif

Attention @patricktoulon ! Entre deux solutions, j'ai toujours été enclin à prendre la plus compliquée. Pourquoi ? Yé né sais pas

 

[cd95]

Bonjour à tous,

Ben ça, c'est ti pas du beau télétravail collaboratif

Bonjour,

Vraiment rien à dire