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 |
Partager