Vba Casse Nom (Prénom) vers NOM (Pénom)

Résolu/Fermé

jaffreux - 7 juin 2011 à 11:31
aqwaq - 6 juin 2012 à 16:34

Bonjour,

Je voudrais savoir si vous connaissez une formule qui transforme une cellule sous cette forme Nom (Prénom) en NOM (Prénom)?
Le séparateur nom prénom est toujours la parenthèse, ce qui évite les erreurs avec les noms ou prénoms composés.
La liste que j'ai à transformé est conséquente et se reproduira régulièrement, c'est pour cela qu'un script m'est utile.
La cerise sur le gâteau serait de que lors de la conversion, le nom se transforme en majuscule non accentuée. Mais qui laisse le prénom en caractère accentué.
Pour infos, je suis nul en programmation mais j'utilise des scripts régulièrement...
J'espère que ce genre de script existe car la solution alternative serait d'éclater cette colonne (grâce au parenthèse). Puis de faire le traitement sur la colonne Nom puis de réunir les deux colonnes, ce qui est assez rébarbatif, surtout si cela doit être fait régulièrement.

Merci d'avance pour votre aide

A voir également:

Vba Casse Nom (Prénom) vers NOM (Pénom)
Nom et prénom - Guide
Nom de l'adresse ✓ - Forum Réseaux sociaux
&Quot;Nom de l'adresse" lors d'une inscription sur une site - Forum Consommation & Internet
Facebook recherche par nom et prénom ✓ - Forum Facebook
Trouver une adresse avec un nom de famille gratuit ✓ - Forum Mobile

8 réponses

Réponse 1 / 8

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
Modifié par pijaku le 7/06/2011 à 11:46

Bonjour,
Pas si simple.
Ce code transforme la cellule active comme tu le souhaites et place le résultat dans la cellule voisine (à droite) :

Option Explicit  
Const accent As String = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç"  
Const noAccent As String = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc"  

Sub test()  
Dim Chaine() As String  
Chaine = Split(ActiveCell.Value, " (")  
ActiveCell.Offset(0, 1).Value = sansAccents(UCase(Chaine(0))) & " (" & Chaine(1)  
End Sub  

'trouvée ici (toujours afficher ces sources!)   
Private Function sansAccents(ByRef Chaine As String) As String
Dim i As Integer
Dim lettre As String
    sansAccents = Chaine
    For i = 1 To Len(accent)
    lettre = Mid(accent, i, 1)
    If InStr(sansAccents, lettre) > 0 Then
        sansAccents = Replace(sansAccents, lettre, Mid(noAccent, i, 1))
    End If
Next i
End Function

Lancer la macro appelée "test"
Cordialement,
Franck P

Réponse 2 / 8

jaffreux
7 juin 2011 à 12:13

Merci pour ta réponse.
Je viens de tester, cela fonctionne.
Un seul problème, le script fonctionne seulement sur 1 cellule, mais pas sur la sélection dans la colonne.
Et si je peux abuser, est ce que l'inverse est possible : NOM (Prénom) vers Nom (Prénom), sans le problème des accents bien entendu.

En tout cas, merci pour ton aide qui m'est d'un grand secours et de la rapidité de ta réponse

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
7 juin 2011 à 12:27

Remplace la procédure "test" de l'ancien code par celle ci :

Sub test()
Dim Chaine() As String
Dim Cel As Range

For Each Cel In Selection
    Chaine = Split(Cel.Value, " (")
    Cel.Offset(0, 1).Value = sansAccents(UCase(Chaine(0))) & " (" & Chaine(1)
    Chaine = Split(Cel.Offset(0, 1).Value, " (")
    Cel.Offset(0, 2).Value = WorksheetFunction.Proper(Chaine(0)) & " (" & Chaine(1)
Next
End Sub

- Boucle sur toutes les cellules préalablement sélectionnées
- écris dans la cellule à droite le NOM en majuscule
- écris dans la cellule 2 colonnes à droites le Nom Majuscule minuscule sans accents...

aqwaq
6 juin 2012 à 15:46

Bonjour, j'ai un problème avec ce code, je le copie dans une macro appelé test, je sélectionne la case mais quand je lance la macro, cela ne marche pas et affiche un message d'erreur en me disant que la fonction sans accent n'est pas définie. Est-ce un pb de compatibilité avec office 2010?

aqwaq
6 juin 2012 à 16:34

Réponse trouvée.

Réponse 3 / 8

jaffreux
7 juin 2011 à 12:55

Génial.

Mais j'ai encore un problème, c'est de ma faute, je n'ai pas donné tous les éléments. Désolé
Dans une cellule, il peut y avoir plusieurs noms séparés par des virgule espace
Ex : Bouquet (Brigitte), Madoui (Mohamed), Nivolle (Patrick)
Avec le test, cela donne ceci : BOUQUET (Brigitte), Madoui

Pour essayer de comprendre, dans ta formule,
Chaine = Split(Cel.Value, " (")
permet de séparer la cellule avec comme séparateur espace(

Cel.Offset(0, 1).Value = sansAccents(UCase(Chaine(0))) & " (" & Chaine(1)
permet d'appliquer sur ce qui est avant ( la formule sans accent
puis de refusionner la cellule

Chaine = Split(Cel.Offset(0, 1).Value, " (")
Permet de faire le deuxième traitement

Cel.Offset(0, 2).Value = WorksheetFunction.Proper(Chaine(0)) & " (" & Chaine(1)
la formule WorksheetFunction.Proper applique a ce qui se trouve avant ( une fonction 1ère lettre de chaque mot en majuscule

Par contre je n'arrive pas à voir où tu dis de mettre les caractère en majuscule. Je pense que c'est dans la fonction sansAccents

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
7 juin 2011 à 12:57

En Majuscule : UCase(ChaineDeCaractère)

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
7 juin 2011 à 12:59

Pour ton autre problème (plusieurs noms) il faut "préparer" ton fichier au préalable. Soit par macro, soit avec Données/Convertir.
Tu dis...

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
7 juin 2011 à 13:13

En cadeau, si tu veux placer tes données séparées par des virgules l'une sous l'autre dans la même colonne :

Sub RangeLesDonnees()
Dim Chaine() As String
Dim Cel As Range
Dim i As Integer

For Each Cel In Selection
    If InStr(Cel.Value, ",") > 0 Then
        Chaine = Split(Cel.Value, ",")
        Rows(Cel.Row + 1 & ":" & Cel.Row + UBound(Chaine)).Insert Shift:=xlDown
        For i = 0 To UBound(Chaine)
            Cel.Offset(i, 0).Value = Trim(Chaine(i))
        Next
    End If
Next
End Sub

Pour info : Trim(ChaineDeCaractères) enlève les espaces à droite et à gauche...

Réponse 4 / 8

jaffreux
7 juin 2011 à 13:17

Je te remercie vivement pour ton travail, tes explications et ta rapidité.
Cela va me permettre de travailler de façon efficace sur ce fichier.
En outre, cela me permet d'approfondir mes connaissances dans la création de script.

Milles merci

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
7 juin 2011 à 13:22

Tu veux apprendre?
Et bien :

Recommandation N°1 pour manipuler les chaines de caractères

Recommandation N°2 pour beaucoup plus en général...

Bonne lecture!

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 8

jaffreux
8 juin 2011 à 10:42

Merci pour tes liens. Même si je ne compte pas pour l'instant me lancer dans ce langage, cela va me permettre de mieux comprendre les scripts que j'utilise et de les modifier (un peu!) si j'en ai le besoin.

Par contre, je viens de regarder mon fichier à transformer, et le fait d'éclater les cellules contenant plusieurs noms ne va pas être techniquement réalisable : Liste trop longue, et des transformations se feront chaque quinzaine.
Je travaille dans un centre de documentation. Je travaille dans un réseau d'échange de notices. Ce réseau vient de changer la manière de saisir les notices différentes de la notre (NOM (Prénom)). Pour notre part, nous préférons garder le format Nom (Prénom). Comme il y a échange régulier de notices, il faut que je trouve un traitement assez simple, sinon, nous devrons adopter les règles du réseau.
Je te mets en lien un exemple de notices à traiter. Ce traitement concernera les colonnes AU, AUCO, AS, et DENP.
http://www.cijoint.fr/cjlink.php?file=cj201106/cijOCaoSeH.xls
Merci de ton aide, même si cela n'est pas possible techniquement

Réponse 6 / 8

jaffreux
8 juin 2011 à 10:44

J'ai un script qui permet de mettre le premier caractère se trouvant après une virgule espace en majuscule, je ne sais pas si cela peut aider.
Sub FirstMajVirgule()
' Permet la mise en majuscule de la première lettre d'une phrase
' et le reste en minuscule. Si la phrase contient un "." alors la
' première lettre du mot suivant sera en majuscule
Dim Plage As Range, Cellule As Range
On Error GoTo Erreur

' Affiche une fenêtre pour choisir la plage ou la cellule
Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)

For Each Cellule In Plage
Cellule = F_Ucase(Cellule.Text)
Next Cellule

Erreur:
If Err.Number = 424 Then Exit Sub

End Sub

Function F_Ucase(Texte As String) As String
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft1 As Integer, icarLeft2 As Integer
Application.Volatile

' Sélection de la cellule
Str1 = Texte
Str1 = LCase(Str1)

'compte la longueur
LongStr = Len(Str1)

'Si la chaîne est vide, sortie
If LongStr = 0 Then Exit Function

'Si chaîne de longueur 1, alors saute à la fin de procédure
If LongStr = 1 Then GoTo PremierCaractere

' boucle à partir de la droite jusqu'au 2ème caractère
For i = LongStr To 3 Step -1
'sort le code du car actif
iCar = Asc(Mid(Str1, i, 1))

'sort le code du car à gauche du car actif
icarLeft1 = Asc(Mid(Str1, i - 1, 1))

' sort le code du 2ème car à gauche du car actif
icarLeft2 = Asc(Mid(Str1, i - 2, 1))

'Si le car actif n'est pas un des 3,alors
If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
'Si le car à gauche est une virgule, alors passe le car actif en majuscule
If icarLeft1 = 44 Then
TempStr = UCase(Chr(iCar))
'si virgule et espace, alors majuscule
ElseIf icarLeft1 = 32 And icarLeft2 = 44 Then
TempStr = UCase(Chr(iCar))
'si retour chariot, alors majuscule
ElseIf icarLeft1 = 10 Then
TempStr = UCase(Chr(iCar))

'sinon le laisse en minuscule
Else
TempStr = Chr(iCar)
End If
Else
'sinon le laisse en minuscule
TempStr = Chr(iCar)
End If

'ajoute le car trouvé à la chaîne
Str2 = Str2 & TempStr
Next i

'gestion du caractère 2
SecondCaractere:
iCar = Asc(Mid(Str1, 2, 1))
icarLeft1 = Asc(Mid(Str1, 1, 1))
If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
If icarLeft1 = 10 Or icarLeft1 = 46 Then
TempStr = UCase(Chr(iCar))
Else
TempStr = Chr(iCar)
End If
Else
TempStr = Chr(iCar)
End If
Str2 = Str2 & TempStr

'gestion du premier caractère
PremierCaractere:
iCar = Asc(Mid(Str1, 1, 1))
If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
TempStr = UCase(Chr(iCar))
Else
TempStr = Chr(iCar)
End If

Str2 = Str2 & TempStr

'inversion de la chaîne trouvée
Str2 = StrReverse(Str2)

'renvoi de la valeur dans la cellule
F_Ucase = Str2
End Function

Réponse 7 / 8

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
8 juin 2011 à 11:38

Salut,
Pas tout compris, mais bon essaye ceci quand même :

Option Explicit
Const accent As String = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç"
Const noAccent As String = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc"

Sub ChangerLeNomEnMajuscules()
Dim ChaineVirg() As String, ChaineParent() As String
Dim Result As String
Dim Cel As Range
Dim i As Integer

For Each Cel In Selection
    If InStr(Cel.Value, ",") > 0 Then
        ChaineVirg = Split(Cel.Value, ",")
    ElseIf Cel.Value <> "" Then
        ReDim ChaineVirg(0)
        ChaineVirg(0) = Cel.Value
    ElseIf Cel.Value = "" Then
        Result = ""
        GoTo Suite
    End If
    On Error Resume Next
    For i = 0 To UBound(ChaineVirg)
        If InStr(ChaineVirg(i), " (") > 0 Then
            ChaineParent = Split(Trim(ChaineVirg(i)), " (")
            Result = Result & sansAccents(UCase(ChaineParent(0))) & " (" & ChaineParent(1) & " ,"
        Else
            Result = Result & ChaineVirg(i) & " ,"
        End If
    Next
    Cel.Value = Left(Result, Len(Result) - 2)
    Result = ""
Suite:
Next
End Sub

Sub ChangerLeNomEnNomPropre()
Dim ChaineVirg() As String, ChaineParent() As String
Dim Result As String
Dim Cel As Range
Dim i As Integer

For Each Cel In Selection
    If InStr(Cel.Value, ",") > 0 Then
        ChaineVirg = Split(Cel.Value, ",")
    ElseIf Cel.Value <> "" Then
        ReDim ChaineVirg(0)
        ChaineVirg(0) = Cel.Value
    ElseIf Cel.Value = "" Then
        Result = ""
        GoTo suivant
    End If
    On Error Resume Next
    For i = 0 To UBound(ChaineVirg)
        If InStr(ChaineVirg(i), " (") > 0 Then
            ChaineParent = Split(Trim(ChaineVirg(i)), " (")
            Result = Result & WorksheetFunction.Proper(ChaineParent(0)) & " (" & ChaineParent(1) & " ,"
        Else
            Result = Result & ChaineVirg(i) & " ,"
        End If
    Next
    Cel.Value = Left(Result, Len(Result) - 2)
    Result = ""
suivant:
Next
End Sub

Private Function sansAccents(ByRef Chaine As String) As String
Dim i As Integer
Dim lettre As String
    sansAccents = Chaine
    For i = 1 To Len(accent)
    lettre = Mid(accent, i, 1)
    If InStr(sansAccents, lettre) > 0 Then
        sansAccents = Replace(sansAccents, lettre, Mid(noAccent, i, 1))
    End If
Next i
End Function

Réponse 8 / 8

jaffreux
8 juin 2011 à 11:54

Je ne sais pas quoi te répondre, c'est exactement ce qu'il me fallait.
Juste une erreur au niveau de la syntaxe pour les cellules avec plusieurs noms.
Mais je pense pouvoir trouver où est le problème.
Vraiment génial

Dans le script : Bouquet (Brigitte) ,Madoui (Mohamed) ,Nivolle (Patrick)
Résultat voulu : Bouquet (Brigitte), Madoui (Mohamed), Nivolle (Patrick)

pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 744
8 juin 2011 à 12:02

Pardon... Le problème vient dans les lignes Result = Result & blabla & " ,"
il faut changer par : Result = Result & blabla & ", "
Soit :

Option Explicit
Const accent As String = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç"
Const noAccent As String = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc"

Sub ChangerLeNomEnMajuscules()
Dim ChaineVirg() As String, ChaineParent() As String
Dim Result As String
Dim Cel As Range
Dim i As Integer

For Each Cel In Selection
    If InStr(Cel.Value, ",") > 0 Then
        ChaineVirg = Split(Cel.Value, ",")
    ElseIf Cel.Value <> "" Then
        ReDim ChaineVirg(0)
        ChaineVirg(0) = Cel.Value
    ElseIf Cel.Value = "" Then
        Result = ""
        GoTo Suite
    End If
    On Error Resume Next
    For i = 0 To UBound(ChaineVirg)
        If InStr(ChaineVirg(i), " (") > 0 Then
            ChaineParent = Split(Trim(ChaineVirg(i)), " (")
            Result = Result & sansAccents(UCase(ChaineParent(0))) & " (" & ChaineParent(1) & ", "
        Else
            Result = Result & ChaineVirg(i) & ", "
        End If
    Next
    Cel.Value = Left(Result, Len(Result) - 2)
    Result = ""
Suite:
Next
End Sub

Sub ChangerLeNomEnNomPropre()
Dim ChaineVirg() As String, ChaineParent() As String
Dim Result As String
Dim Cel As Range
Dim i As Integer

For Each Cel In Selection
    If InStr(Cel.Value, ",") > 0 Then
        ChaineVirg = Split(Cel.Value, ",")
    ElseIf Cel.Value <> "" Then
        ReDim ChaineVirg(0)
        ChaineVirg(0) = Cel.Value
    ElseIf Cel.Value = "" Then
        Result = ""
        GoTo suivant
    End If
    On Error Resume Next
    For i = 0 To UBound(ChaineVirg)
        If InStr(ChaineVirg(i), " (") > 0 Then
            ChaineParent = Split(Trim(ChaineVirg(i)), " (")
            Result = Result & WorksheetFunction.Proper(ChaineParent(0)) & " (" & ChaineParent(1) & ", "
        Else
            Result = Result & ChaineVirg(i) & ", "
        End If
    Next
    Cel.Value = Left(Result, Len(Result) - 2)
    Result = ""
suivant:
Next
End Sub

Private Function sansAccents(ByRef Chaine As String) As String
Dim i As Integer
Dim lettre As String
    sansAccents = Chaine
    For i = 1 To Len(accent)
    lettre = Mid(accent, i, 1)
    If InStr(sansAccents, lettre) > 0 Then
        sansAccents = Replace(sansAccents, lettre, Mid(noAccent, i, 1))
    End If
Next i
End Function

Discussions similaires

"Nom de l'adresse" lors d'une inscription sur une site

Annuaire portable gratuit à partir d'un nom

Nom d’adresse

Trouver un nom avec une adresse

Comment trouver un numéro à partir du nom et prénom

Discussions similaires

Newsletters