XL 2021 Rechercher les prénoms

[sonskriverez]

Bonjour le Forum,

Dans mon fichier j'ai 2 onglets et phrase. Je voudrais en utilsant les prénoms de l'onglet "Prénoms", surlignier toutes les cellules de l'onglet "Phrase" contenant un prénom.

MErci de votre aide

 

[patricktoulon]

Autant pour moi il m'a échappé avec PQ le 6506

 

[Cousinhub]

Bonsoir,
Pour le fun
Bonne soirée

 

[mapomme]

Bonsoir à tous 😉,

Je suis épaté par la liste des prénoms qui sont aussi des mots n'étant pas un prénom. En voici quelques uns :
Ace, Africa, Adora, Ah, An, Amen, Ami, Art, Bas, Beau, Avis, Belle, Aurore, Bile, Blanche, Cher, Ciel, Colombe, Da, Demi, Don, Duc , Echo, Edit, Fiacre, Fleur, Fortune, France, Gage, Gala, Germain, Germaine, Gosse...

Entre des orthographes fantaisistes, des accents omis, des prénoms cons, quel est donc le taux de réussite pertinente d'une recherche de prénoms dans une phrase ? Peut-être faudrait-il passer par une compréhension du sens pour déterminer si un mot est un prénom ou pas. Et même avec cette méthode, je suis à peu près certain qu'il y aurait des erreurs.

nota : le prénom "Les" en est un des plus magnifiques représentants.

 

[vgendron]

Bonsoir à tous 😉,

Je suis épaté par la liste des prénoms qui sont aussi des mots n'étant pas un prénom. En voici quelques uns :
Ace, Africa, Adora, Ah, An, Amen, Ami, Art, Bas, Beau, Avis, Bell, Aurore, Bile, Blanche, Cher, Ciel, Colombe, Da, Demi, Don, Duc , Echo, Edit, Fiacre, Fleur, Fortune, France, Gage, Gala, Germain, Germaine, Gosse...

Entre des orthographes fantaisistes, des accents omis, des prénoms cons, quel est donc le taux de réussite pertinente d'une recherche de prénoms dans une phrase ? Peut-être faudrait-il passer par une compréhension du sens pour déterminer si un mot est un prénom ou pas. Et même avec cette méthode, je suis à peu près certain qu'il y aurait des erreurs.

nota : le prénom "Les" en est un des plus magnifiques représentants.

manque plus que les prénoms a - e - i - o - u - y

plus besoin de tester quoique ce soit. tout en rouge direct

 

[fanch55]

Bonjour à tous,
Il est vrai que la liste des prénoms a un assez "large spectre", certains prénoms risquent de ne pas être "trouvés"

etc ... il y a même un "Sans" prénom ...

Certaines lignes de "Phrase" sont en erreur :

Le code ci-dessous est à mettre dans un module, lancer la Sub Souligne_Prénoms(),
le temps d'exécution est de l'ordre de 3 à 4 secondes au mieux selon la mémoire disponible , il faut dire qu'on travaille le contenu de chaque cellules de "Phrase"

Option Compare Text
Option Explicit
Dim Tb
Sub Souligne_Prénoms()
Dim Cel As Range, Lr As Long, FTimer
    FTimer = Timer
    Charge_Prénoms
    Lr = Worksheets("Phrase").Cells(Worksheets("Phrase").Rows.Count, "B").End(xlUp).Row
    For Each Cel In Worksheets("Phrase").Range("B2:B" & Lr).Cells
        Colore_Cel Cel
    Next
    MsgBox "Opération terminée en " & Timer - FTimer & " s"
End Sub
Function Colore_Cel(Cel As Range)
Application.ScreenUpdating = False
Dim D As Integer, Ws, W, I As Integer
If Not IsError(Cel) Then
    D = 0
    Ws = Split(Replace(Cel, "'", " "))
    For Each W In Ws
        If W <> "" Then
            For I = 1 To Tb.Count
                If Tb(I).Exists(UCase(W)) Then
                    D = InStr(D + 1, Cel, W, vbTextCompare)
                    Cel.Characters(D, Len(W)).Font.Color = vbRed
                    Cel.Characters(D, Len(W)).Font.Underline = xlUnderlineStyleSingle
                    Exit For
                End If
            Next
        End If
    Next
End If
End Function
Sub Charge_Prénoms()
Dim Cel As Range, I As Long, Lr As Long
    I = 1
    Set Tb = CreateObject("Scripting.Dictionary")
    Set Tb(I) = CreateObject("Scripting.Dictionary")
    Lr = Worksheets("Prénoms").Cells(Worksheets("Prénoms").Rows.Count, "A").End(xlUp).Row
    For Each Cel In Worksheets("Prénoms").Range("A2:A" & Lr)
        Tb(I)(UCase(Cel.Text)) = 0
      ' 256 éléments max par dictionnaire
        If Tb(I).Count = 256 Then
            I = I + 1
            Set Tb(I) = CreateObject("Scripting.Dictionary")
        End If
    Next
End Sub