Vba Casse Nom (Prénom) vers NOM (Pénom) Résolu/Fermé

Question

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


Configuration: Windows Vista / Firefox 3.6.17

pijaku · Answer

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

jaffreux · Answer

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

jaffreux · Answer

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

jaffreux · Answer

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

jaffreux · Answer

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

jaffreux · Answer

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

pijaku · Answer

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

jaffreux · Answer

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)

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

8 réponses

Discussions similaires