Discussion :

[jeancharles1988]

Bonjour,

Je travaille actuellement sur un fichier sur lequel je rencontre une problématique.
Je m'explique :
Ce fichier se compose d'une colonne et de quelques milliers de lignes contenant des chaines de caractères sous différentes formes, recensant des infos de personnes.
ex: "Dupontgérard" "gérarddupont" "Dgérard"...
J'aurais besoin de récupérer les Prénoms associés à chacune de ces chaines de caractères.
Pour cela j'ai récupéré une base de données de prénoms existants qui semble assez complète.
L'idée serait de vérifier si chacune de mes chaines de caractères comporte un des prénoms présent dans ma BDD.
J'ai commencé à regarder comment faire mais je bloque un peu.
Si vous pourriez m'éclairer ce serait super cool

Merci

[Invité]

Bonjour,

Une solution possible avec le fichier exemple joint :

Dans un module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub RechercherLesPrenoms()
 
Dim ShPrenoms As Worksheet
Dim ShListe As Worksheet
 
Dim AirePrenoms As Range
Dim CellulePrenoms As Range
Dim AireListe As Range
Dim CelluleListe As Range
Dim PrenomRecherche As Range
 
Dim DerniereLigne As Long
 
 
    Set ShPrenoms = Sheets("Prénoms")
    Set ShListe = Sheets("Liste")
    DerniereLigne = ShPrenoms.Cells(ShPrenoms.Rows.Count, 1).End(xlUp).Row
    Set AirePrenoms = ShPrenoms.Range(ShPrenoms.Cells(2, 1), ShPrenoms.Cells(DerniereLigne, 1))
 
    DerniereLigne = ShListe.Cells(ShListe.Rows.Count, 2).End(xlUp).Row
    Set AireListe = ShListe.Range(ShListe.Cells(11, 2), ShListe.Cells(DerniereLigne, 2))
    AireListe.Offset(0, 1).ClearContents
 
    For Each CellulePrenoms In AirePrenoms
        For Each CelluleListe In AireListe
            Set PrenomRecherche = CelluleListe.Find(What:=UCase(CellulePrenoms), LookIn:=xlValues)
            If Not PrenomRecherche Is Nothing Then
                   PrenomRecherche.Offset(0, 1) = CellulePrenoms
            End If
            Set PrenomRecherche = Nothing
        Next CelluleListe
    Next CellulePrenoms
 
    Set AirePrenoms = Nothing
    Set AireListe = Nothing
    Set ShPrenoms = Nothing
    Set ShListe = Nothing
 
 
End Sub

La macro fonctionne pour les différents cas de votre exemple.


Recherche de prénoms

[jeancharles1988]

Bonjour Eric,

C'est exactement ça, merci beaucoup