[VBA]Séparer le Nom et le Prénom placés dans une cellule unique

[ouskel'n'or]

Le but : Séparer le nom du prénom réunis dans une colonne unique pour les répartir dans deux colonnes

......Sur une idée de beegees -> Tester les minuscules pour détecter le prénom
......Une méthode de bbil -> Créer un tableau des mots dans nom+prénom
......L'extrapolation d'une idée de dadavyvy -> Tester la casse des caractères,
......et sa participation active dans l'examen des différents cas de figures
......à prendre en compte -> Doubles espaces, option binary...

Restait plus qu'à...

Ce code ne fonctionne que si les noms sont en majuscules, les prénoms n'ont que le premier caractère en majuscule, le reste en minuscules.

Pris en compte :
- Les noms ou les prénoms composés
- Les noms ou les prénoms accentués ou non
- Les noms comportant des apostrophes
- Les noms précédant le prénom
- Les noms précédés du prénom
- Les noms ou prénoms séparés par plusieurs espaces

Les données sont insérées dans la feuille contenant les NomPrénoms. Pour cela une colonne est insérée pour les prénoms à droite de la colonne des noms.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Option Explicit
Option Compare Binary 'Seulement utile si vous avez 'Option Compare Text...
                      '... quelque part dans le code précédent cette macro
Sub Lecture()
Dim NoCol As Integer
Dim Ws As Worksheet
Dim Cel As Range
    Set Ws = Worksheets("Feuil1") 'Feuille analysée
    NoCol = 5 'Colonne lue
    'Insertion à droite de la colonne "Nom" d'une colonne "Prénom"
    Ws.Columns(NoCol + 1).Insert Shift:=xlToRight
    Ws.Cells(1, NoCol + 1) = "Prénom" 'entête de colonne
    'Parcours de la colonne à partir de la seconde ligne
    For Each Cel In Ws.Range(Ws.Cells(2, NoCol), _
        Ws.Cells(Ws.Range(Ws.Cells(1, NoCol).Address). _
        SpecialCells(xlCellTypeLastCell).Row, NoCol))
        If Not Cel Is Nothing Then
            Call Ecriture(Ws, NoCol, Cel.Value, Cel.Row)
        Else
            Exit For 'Rien dans la cellule, on quitte
        End If
    Next
End Sub
 
Sub Ecriture(Ws, NoCol, NomPrenom, WsRow)
Dim st As String, tb() As String
Dim n As Integer
Dim LeNom As String, Prenom As String, LeCar As String
Dim pr As Boolean, WsRange As Range
    st = NomPrenom
    tb = Split(st, " ")
    For n = 0 To UBound(tb)
        If tb(n) <> "" Then ''Pour dadavyvy qui mets plein d'espaces entre les mots ^^^
            'On vérifie que le dernier caractère du mot est une minuscule
            If Asc(Right(LCase(tb(n)), 1)) = Asc(Right(tb(n), 1)) Then
                Prenom = Prenom & " " & tb(n)
            Else 'Pas de minuscule, c'est le nom
                LeNom = LeNom & " " & tb(n)
            End If
        End If
    Next
    Set WsRange = Ws.Cells(WsRow, NoCol)
    WsRange.Value = Trim(LeNom)
    WsRange.Offset(0, 1).Value = Trim(Prenom)
End Sub

Ouf !

NB - Après moulte tests, il n'en demeure pas moins un pb : Les noms qui se terminent par une apostrophe sont considérés comme des prénoms.
Ainsi, "JÉPERDUL' Truc" met tout dans la colonne prénom... Faudra faire attention