Vba nettoyer une liste de noms propres

Soyez le premier à donner votre avis sur cette source.

Snippet vu 4 137 fois - Téléchargée 20 fois

Commenter

Contenu du snippet

Je souhaitais analyser des données saisies dans un fichier excel en utilisant un tableau croisé dynamique. Cependant, la liste des noms (angle principal d'analyse) a été saisie au fil de l'eau sous de nombreuses formes (M Dupont, M. DuPont, Mr Dupont, Laurent Dupont, M. Laurent Dupont, ...).
Ce n'est pas pratique pour regrouper toutes les lignes qui le devraient.
Je propose un code qui "néttoie" la liste des noms propres.
On peut :
- nettoyer la liste en supprimant le "genre" (M,Mme, ...)
- faire passer le prénom après le nom
- supprimer le prénom
Les listes de préfixes à supprimer ou de prénoms gérés se modifient facilement dans le code. Faire juste attention à l'ordre de présentation dans la liste des prénoms : pour gérer "jean-luc" et "jean-louis" ... il faut les placer avant "jean" dans la liste des prénoms sinon il vous restera "-luc" ou "-louis" dans votre colonne !
les paramètres decal_Lig et decal_col permettent de choisir entre un remplacement de la liste par la liste modifiée (paramètres à 0) ou la création d'une liste modifiée à decal_Lig lignes et/ou decal_col colonnes de la source.

Source / Exemple : 


Sub Clean_nomP(Optional MaZone As Range, Optional PrenomApresT_SansF As Boolean = False, Optional Decal_Lig As Integer = 0, Optional Decal_Col As Integer = 0)
If MaZone Is Nothing Then Set MaZone = ActiveCell.CurrentRegion
Dim rg As Range, rgc As Range
Dim Mesprénoms(66) As String
Dim combien As Integer, i As Integer
combien = 66

GoTo Stock
Suite::
For Each rg In MaZone
    Set rgc = rg.Offset(Decal_Lig, Decal_Col)
    rgc.Value = Trim(rg.Value)
    rgc.Value = Application.WorksheetFunction.Clean(rgc.Value)
    rgc.Value = Replace(rgc.Value, "M.G", "M. G", 1)
    rgc.Value = Replace(rgc.Value, "M ", "", 1)
    rgc.Value = Replace(rgc.Value, "M. ", "", 1)
    rgc.Value = Replace(rgc.Value, "M, ", "", 1)
    rgc.Value = Replace(rgc.Value, "Mme ", "", 1)
    rgc.Value = Replace(rgc.Value, "Mme. ", "", 1)
    rgc.Value = Replace(rgc.Value, "MME ", "", 1)
    rgc.Value = Replace(rgc.Value, "MR ", "", 1)
    rgc.Value = Replace(rgc.Value, "Mr ", "", 1)
    rgc.Value = Trim(rgc.Value)
    For i = 1 To combien
        If PrenomApresT_SansF Then
            rgc.Value = Prénom_après(rgc.Value, Mesprénoms(i))
        Else
            rgc.Value = Application.WorksheetFunction.Clean(Trim(Replace(rgc.Value, Mesprénoms(i), "", 1)))
        End If
    Next i
    rgc.Value = UCase(rgc.Value)
Next rg
Exit Sub
Stock::

Mesprénoms(1) = "Agnès"
Mesprénoms(2) = "Alain"
Mesprénoms(3) = "Alban"
Mesprénoms(4) = "Alter"
Mesprénoms(5) = "Anne"
Mesprénoms(6) = "Annick"
Mesprénoms(7) = "Antoine"
Mesprénoms(8) = "Arlette"
Mesprénoms(9) = "Bertrand"
Mesprénoms(10) = "Brigitte"
Mesprénoms(11) = "Bruno"
Mesprénoms(12) = "Cath."
Mesprénoms(13) = "Cécile"
Mesprénoms(14) = "Christian"
Mesprénoms(15) = "Christian"
Mesprénoms(16) = "Christine"
Mesprénoms(17) = "Christophe"
Mesprénoms(18) = "Daniel"
Mesprénoms(19) = "Déborah"
Mesprénoms(20) = "Emily"
Mesprénoms(21) = "Emmanuel"
Mesprénoms(22) = "Eric"
Mesprénoms(23) = "Fabien"
Mesprénoms(24) = "Franck"
Mesprénoms(25) = "Frédérique"
Mesprénoms(26) = "Gilles"
Mesprénoms(27) = "Guillaume"
Mesprénoms(28) = "Henri"
Mesprénoms(29) = "Hubert"
Mesprénoms(30) = "J.A."
Mesprénoms(31) = "J.Bruno"
Mesprénoms(32) = "Jacques"
Mesprénoms(33) = "JB"
Mesprénoms(34) = "JC"
Mesprénoms(35) = "Jean Yves"
Mesprénoms(36) = "Jean Bruno"
Mesprénoms(37) = "Jean Christian"
Mesprénoms(38) = "Jean Jacques"
Mesprénoms(39) = "Jean Luc"
Mesprénoms(40) = "Jean"
Mesprénoms(41) = "Jérôme"
Mesprénoms(42) = "Julie"
Mesprénoms(43) = "Kenza"
Mesprénoms(44) = "Laurence"
Mesprénoms(45) = "Laurent"
Mesprénoms(46) = "Marine"
Mesprénoms(47) = "Michèle"
Mesprénoms(48) = "Nathalie"
Mesprénoms(49) = "Olivier"
Mesprénoms(50) = "Pascal"
Mesprénoms(51) = "Patricia"
Mesprénoms(52) = "Patrick"
Mesprénoms(53) = "Philippe"
Mesprénoms(54) = "Pierre"
Mesprénoms(55) = "Régine"
Mesprénoms(56) = "Savina"
Mesprénoms(57) = "Sophie"
Mesprénoms(58) = "Téresa"
Mesprénoms(59) = "Thierry"
Mesprénoms(60) = "Thomas"
Mesprénoms(61) = "Valérie"
Mesprénoms(62) = "Victor"
Mesprénoms(63) = "Virginie"
Mesprénoms(64) = "Wilfried"
Mesprénoms(65) = "William"
Mesprénoms(66) = "Yves"

GoTo Suite

End Sub

Function Prénom_après(Quoi As String, Prenom As String)
Prénom_après = Quoi
If UCase(Left(Quoi, Len(Prenom) + 1)) = UCase(Prenom + " ") Then
    Prénom_après = Trim(UCase(Right(Quoi, Len(Quoi) - Len(Prenom) - 1))) + " " + Prenom
End If
End Function

Conclusion :


pour appeler la routine :
Call Clean_nomP(Range("S1:S1000" ), False, 0, 1)
voire, tout simplement, avec le curseur / la selection dans la colonne à traiter :
Clean_nomP

Je suis preneur d'autres astuces de nettoyage de données ;)

A voir également

Ajouter un commentaire Commentaires
cs_MPi Messages postés 3877 Date d'inscription mardi 19 mars 2002 Statut Membre Dernière intervention 17 août 2018 22
22 mars 2012 à 10:51
Bonjour,

Tu pourrais aussi utiliser une feuille dans laquelle tu inscris tes prénoms et tu charges cette liste dans un tableau() avec peu de code. Ce serait plus simple que de retourner dans le code et modifier soit le code, soit le tableau...

ex:
Dim MonTableau as Variant, nbLignes as long
nbLignes = Sheets("Prénoms").cells(rows.count, "A").end(xlup).row
MonTableau = sheets("Prénoms").range("A2:A" & nbLignes).value

Il s'agit ensuite de boucler le tableau généré en utilisant UBound(MonTableau)
klhsri Messages postés 6 Date d'inscription vendredi 19 octobre 2007 Statut Membre Dernière intervention 2 janvier 2009
21 mars 2012 à 19:52
Salut,
D'accord pour le tableau et l'esthetique... Pour le malléable on peut discuter ... Pour en ajouter il s'y pouffait de copier coller la ligne et changer la chaîne ;). Sinon il faut recaler les dimensions et l'index...

Pour le "choix" des prénoms, j'ai utilisé le cas sur lequel je travaillais... Pas de prétention à l'exhaustivité. Ok, pour commencer à l'index 0 (paresse ;(
NHenry Messages postés 15083 Date d'inscription vendredi 14 mars 2003 Statut Modérateur Dernière intervention 19 septembre 2023 159
21 mars 2012 à 13:53
Bonjour,

Pas terrible comme méthode :
- Tu peux faire un tableau des chaines à remplacer plutot que tout tes Replace consécutifs, ce sera plus propre et plus maléable.
- Et les autres prénoms ? Hamed, Julien, Didire, ... ?
- Pourquoi limiter Mesprénoms à 67 éléments et sans utiliser le premier ?
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (klhsri)