Vba nettoyer une liste de noms propres

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

Du même auteur (klhsri)