Vba nettoyer une liste de noms propres

Soyez le premier à donner votre avis sur cette source.

Snippet vu 3 302 fois - Téléchargée 18 fois

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

NHenry
Messages postés
14569
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
19 octobre 2019
136 -
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 ?
klhsri
Messages postés
6
Date d'inscription
vendredi 19 octobre 2007
Statut
Membre
Dernière intervention
2 janvier 2009
-
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 ;(
cs_MPi
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
15 -
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)

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.