Extraire une valeur sur la base d'une table de référence

Le 18/08/2017 à 14:35

Bonjour.

Je souhaiterais extraire des prénom d'une chaine de caractère, en m'appuyant sur une base de prénom référent.

En gros, j'ai un listing de prénom :

  • Anne
  • Ariane
  • Amélie
  • Paul
  • Pauline
  • ...

Une suite de chaines texte :

  • Mme Ariane Tartampion
  • Mr. Paul Dupont
  • Edouard Durand
  • Anne.Durien@xxx.com
  • ...

=> Je voudrais avoir une colonne où je retrouve, à côté du champ texte complet, le prénom extrait.

Difficultés complémentaires :

  • Certains prénoms (type "Paul" et "Pauline" commencent pareil, donc il faut réussir à vérifier que c'est le bon prénom complet
  • Parfois il y a un espace entre les mots, parfois nom (cf l'exemple avec l'email)
  • Parfois il y a des "Pauline Martin" qui ont donc deux "prénoms" identifiables. On partirait du principe que ce serait le premier prénom le bon

Y'a-t-il une solution pas trop complexe pour me dépatouiller de ce sujet ?

Je ne sais pas trop par où commencer à chercher !

Merci

Le 18/08/2017 à 14:47

Salut,

Oui, en VBA c'est possible. Il faut séparer le nom et prénom et inscrire le prénom dans la cellule correspondante.

Peut-tu mettre un fichier qu'on puisse voir ? (Enlève les informations confidentiel).

Cdlt,

Le 18/08/2017 à 15:11

Merci.

Toutes les infos sont confidentielles, donc j'ai fait un faux fichier d'exemple

J'ai mis le début de la liste de prénom : je la terminerai si je trouve une solution technique à mon problème.

j'ai mis des exemples de chaines de valeurs que je pourrais être amené à traiter, et le prénom qui doit en être extrait à droite.

9exemple.xlsx (45.71 Ko)
Le 18/08/2017 à 15:46

Re,

Je pense que tu peux abandonner, désolé mais les données de base n'ont aucune cohérences. Il est impossible, de mon point de vue et sauf erreur de ma part, d'extraire un prénom à partir de tel données brutes.

Si cela se présentait seulement sous la forme de "NOM PRENOM" ou "NOM PRENOM PRENOM" sa serait possible. Cependant, dans ton exemple les valeurs de bases sont trop complexes (<adriano.tarti@gmail.com>; ?windows-1252?Q?Aristide?;).

Un ordinateur ne peut pas reconnaître un prénom juste parce que s'en est un, pour lui c'juste une chaîne de caractères ^^.

Cdlt,

Le 18/08/2017 à 15:52

Bonjour,

une proposition qui devrait convenir pour 99,9% des cas

Sub aargh()
    With Sheets("baseprenoms")
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & n).Copy .Range("B1")
        .Range("C1").Formula = "=upper(B1)"
        .Range("C1").Copy .Range("C2:C" & n)
        .Range("D1").Formula = "=len(C1)"
        .Range("D1").Copy .Range("D2:D" & n)
        .Range("B1:D" & n).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
        Set ws = Sheets("data")
        k = 2
        While ws.Cells(k, 1) <> ""
            For i = 1 To n
                If InStr(UCase(ws.Cells(k, 1)), .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): Exit For
            Next i
            k = k + 1
        Wend
        .Columns("B:D").Delete
    End With
End Sub
Le 18/08/2017 à 16:25

Bonjour,

une version un peu plus élaborée

Sub aargh()
    With Sheets("baseprenoms")
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & n).Copy .Range("B1")
        .Range("C1").Formula = "=upper(B1)"
        .Range("C1").Copy .Range("C2:C" & n)
        .Range("D1").Formula = "=len(C1)"
        .Range("D1").Copy .Range("D2:D" & n)
        .Range("B1:D" & n).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
        Set ws = Sheets("data")
        k = 2
        While ws.Cells(k, 1) <> ""
            tr = "<>.,?@"
            For i = 1 To Len(tr)
                a = UCase(Replace(ws.Cells(k, 1), Mid(tr, i, 1), " "))
            Next i
            b = Split(a, " ")
            fin = False
            For j = LBound(b) To UBound(b)
                lb = Len(b(j))
                Set re = .Range("D1:D" & n).Find(lb, lookat:=xlWhole)
                If Not re Is Nothing Then
                    For i = re.Row To n
                        If .Cells(i, 4) <> lb Then Exit For
                        If InStr(b(j), .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                    Next i
                End If
                If fin Then Exit For
            Next j
            If Not fin Then
                For i = 1 To n
                    If InStr(a, .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                Next i
            End If
            k = k + 1
        Wend
        .Columns("B:D").Delete
    End With
End Sub
Le 18/08/2017 à 16:41
h2so4 a écrit :

Bonjour,

une version un peu plus élaborée

Sub aargh()
    With Sheets("baseprenoms")
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & n).Copy .Range("B1")
        .Range("C1").Formula = "=upper(B1)"
        .Range("C1").Copy .Range("C2:C" & n)
        .Range("D1").Formula = "=len(C1)"
        .Range("D1").Copy .Range("D2:D" & n)
        .Range("B1:D" & n).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
        Set ws = Sheets("data")
        k = 2
        While ws.Cells(k, 1) <> ""
            tr = "<>.,?@"
            For i = 1 To Len(tr)
                a = UCase(Replace(ws.Cells(k, 1), Mid(tr, i, 1), " "))
            Next i
            b = Split(a, " ")
            fin = False
            For j = LBound(b) To UBound(b)
                lb = Len(b(j))
                Set re = .Range("D1:D" & n).Find(lb, lookat:=xlWhole)
                If Not re Is Nothing Then
                    For i = re.Row To n
                        If .Cells(i, 4) <> lb Then Exit For
                        If InStr(b(j), .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                    Next i
                End If
                If fin Then Exit For
            Next j
            If Not fin Then
                For i = 1 To n
                    If InStr(a, .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                Next i
            End If
            k = k + 1
        Wend
        .Columns("B:D").Delete
    End With
End Sub

Salut, comment distingue tu le nom ou le prénom ? Merci.

Cdlt,

Le 18/08/2017 à 16:50

Merci beaucoup, cela semble marcher au poil.

J'avais presque l'impression d'avoir compris sur ta première version (il n'y avait que la ligne la plus importante que je ne comprenais pas), mais sur la version plus aboutie je suis complètement paumé

Bon, en tout cas cela semble marcher.

je vais faire le test avec plus de données pour vérifier.

Merci beaucoup !

Le 18/08/2017 à 17:26
VH_AE a écrit :

Salut, comment distingue tu le nom ou le prénom ? Merci.

Cdlt,

j'ai programmé suivant l'hypothèse que le premier prénom trouvé est le prénom. (sauf pour le cas où il y a 2 prénoms accolés, exemple francoismartin@gmail.com. Dans ce cas c'est le prénom le plus long qui sera sélectionné)

Le 18/08/2017 à 22:16
h2so4 a écrit :

Bonjour,

une version un peu plus élaborée

Question complémentaire : comment faire pour que les accents ou caractères spéciaux ("ç", "tirets") ne posent pas de problème ?

Actuellement, si il y a un accent d'un côté (base de prénom ou data) mais pas de l'autre, ils sont considérés comme différents.

Le 19/08/2017 à 11:55

bonjour,

une nouvelle proposition pour la gestion des accents et cédille + correction bug.

Sub aargh()
    With Sheets("baseprenoms")
        ' à compléter éventuellement
        ' --------------------------
        s1 = UCase("éèçàîï")    ' liste des caractères à remplacer par une des lettres de l'alphabet
        s2 = "EECAII"  ' liste des caractères de remplacement correspondant à s1
        s3 = "-´`'"    ' liste des caractères à supprimer
        tr = "<>.,?@"    'liste des caractères à considérer comme séparateur
        ' --------------------------

        n = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & n).Copy .Range("B1")
        .Range("C1").Formula = "=upper(B1)"
        .Range("C1").Copy .Range("C2:C" & n)
        .Range("C1:C" & n).Copy
        .Range("C1").PasteSpecial xlValues
        For i = 1 To Len(s1)
            .Range("C1:C" & n).Replace Mid(s1, i, 1), Mid(s2, i, 1)
        Next i
        For i = 1 To Len(s1)
            .Range("C1:C" & n).Replace Mid(s3, i, 1), ""
        Next i
        .Range("D1").Formula = "=len(C1)"
        .Range("D1").Copy .Range("D2:D" & n)
        .Range("B1:D" & n).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
        Set ws = Sheets("data")
        k = 2
        While ws.Cells(k, 1) <> ""
            a = UCase(ws.Cells(k, 1))
            For i = 1 To Len(tr)
                a = Replace(a, Mid(tr, i, 1), " ")
            Next i
            For i = 1 To Len(s1)
                a = Replace(a, Mid(s1, i, 1), Mid(s2, i, 1))
            Next i
            For i = 1 To Len(s3)
                a = Replace(a, Mid(s3, i, 1), "")
            Next i
            b = Split(a, " ")
            fin = False
            For j = LBound(b) To UBound(b)
                lb = Len(b(j))
                Set re = .Range("D1:D" & n).Find(lb, lookat:=xlWhole)
                If Not re Is Nothing Then
                    For i = re.Row To n
                        If .Cells(i, 4) <> lb Then Exit For
                        If InStr(b(j), .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                    Next i
                End If
                If fin Then Exit For
            Next j
            If Not fin Then
                For i = 1 To n
                    If InStr(a, .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                Next i
            End If
            k = k + 1
        Wend
        .Columns("B:D").Delete
    End With
End Sub
Le 19/08/2017 à 14:06

Merci beaucoup !

J'ai passé le "-" dans les symboles à considérer comme séparateur.

De cette manière, "Jean-François" sera bien reconnu comme un prénom unique (sinon il ne conserve que François).

Le 19/08/2017 à 15:03

bonjour,

J'ai passé le "-" dans les symboles à considérer comme séparateur.

De cette manière, "Jean-François" sera bien reconnu comme un prénom unique (sinon il ne conserve que François).

je dois avouer que ce résultat me surprend et que je n'ai pas pu le reproduire.

une nouvelle version

Sub aargh()
    With Sheets("baseprenoms")
        ' à compléter éventuellement
        '
        s1 = UCase("éèçàîï")    ' liste des caractères à remplacer par une des lettres de l'alphabet
        s2 = "EECAII"  ' liste des caractères de remplacement correspondant à s1
        s3 = "-´`'"    ' liste des caractères à supprimer
        tr = "<>.,?@"    'liste des caractères à considérer comme séparateur
        '

        n = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & n).Copy .Range("B1")
        .Range("C1").Formula = "=upper(B1)"
        .Range("C1").Copy .Range("C2:C" & n)
        .Range("C1:C" & n).Copy
        .Range("C1").PasteSpecial xlValues
        For j = 1 To n
            a = .Range("C" & j)
            For i = 1 To Len(s1)
                a = Replace(a, Mid(s1, i, 1), Mid(s2, i, 1))
            Next i
            For i = 1 To Len(s3)
                a = Replace(a, Mid(s3, i, 1), "")
            Next i
            .Range("C" & j) = a
        Next j
        .Range("D1").Formula = "=len(C1)"
        .Range("D1").Copy .Range("D2:D" & n)
        .Range("B1:D" & n).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
        Set ws = Sheets("data")
        k = 2
        While ws.Cells(k, 1) <> ""
            a = UCase(ws.Cells(k, 1))
            For i = 1 To Len(tr)
                a = Replace(a, Mid(tr, i, 1), " ")
            Next i
            For i = 1 To Len(s1)
                a = Replace(a, Mid(s1, i, 1), Mid(s2, i, 1))
            Next i
            For i = 1 To Len(s3)
                a = Replace(a, Mid(s3, i, 1), "")
            Next i
            b = Split(a, " ")
            fin = False
            For j = LBound(b) To UBound(b)
                lb = Len(b(j))
                Set re = .Range("D1:D" & n).Find(lb, lookat:=xlWhole)
                If Not re Is Nothing Then
                    For i = re.Row To n
                        If .Cells(i, 4) <> lb Then Exit For
                        If InStr(b(j), .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                    Next i
                End If
                If fin Then Exit For
            Next j
            If Not fin Then
                For i = 1 To n
                    If InStr(a, .Cells(i, 3)) <> 0 Then ws.Cells(k, 2) = .Cells(i, 2): fin = True: Exit For
                Next i
            End If
            k = k + 1
        Wend
        .Columns("B:D").Delete
    End With
End Sub
Le 19/08/2017 à 22:14

En fait, j'ai mis "jean francois" dans le listing des prénoms de référence.

Et du coup, le "Jean-François" présent dans la données à extraire est bien reconnu (en tant que "jean françois" certes, cad que je perds le "-" au passage, mais je suis sûr de mon identification).

Peux-tu me dire quelles sont les modifications apportées par ton nouveau code ?

Je suis un peu perdu et ne sais pas ce qu'il faut que je teste

Le 20/08/2017 à 11:22

bonjour,

les modifications concernent le remplacement des caractères qui semblait ne pas se faire correctement (notamment le - et le ç).

tu devrais pouvoir mettre Jean-François dans ta base des prénoms. cela devrait fonctionner maintenant.

Le 21/08/2017 à 10:28

Rechercher des sujets similaires à "extraire valeur base table reference"