Une sympathique fonction pour taper Prénom + Nom

[Magic_Doctor]

J'avais concocté cette fonction (m'inspirant d'autres...). Autant que ceux intéressés en profitent...
Tapez tout en minuscule. S'il y a des espaces excédentaires, pas de broblème. Plus de problèmes non plus avec les noms avec particules (de Machin) et autres McZinzin... Tout se corrige automatiquement ! Vraiment pratique si vous devez taper quantité d'identités.

Code :

Public Function FirstLetterMaj(Nom_Prénom As Range)

Dim Morceaux() As String, temp As String, EspacesDoubles As String
Dim i As Integer, np As String, s As String

np = LCase(Nom_Prénom.Value)

EspacesDoubles = Chr(32) & Chr(32)
temp = Trim(np)
Do Until InStr(temp, EspacesDoubles) = 0
temp = Replace(temp, EspacesDoubles, Chr(32))
Loop

np = temp

Morceaux = Split(np, " ")
For i = LBound(Morceaux) To UBound(Morceaux)
If Morceaux(i) = "de" Or Morceaux(i) = "del" Or Morceaux(i) = "la" Or Morceaux(i) = "las" Or Morceaux(i) = "los" Or Morceaux(i) = "da" Or Morceaux(i) = "do" Or Morceaux(i) = "di" Or Morceaux(i) = "van" Or Morceaux(i) = "von" Or Morceaux(i) = "der" Then
s = s & (Morceaux(i)) & " "
ElseIf Left(Morceaux(i), 2) = "mc" Then
Morceaux(i) = "Mc" & UCase(Mid(Morceaux(i), 3, 1)) & Right(Morceaux(i), Len(Morceaux(i)) - 3)
s = s & (Morceaux(i)) & " "
Else
s = s & WorksheetFunction.Proper(Morceaux(i)) & " "
End If
Next
FirstLetterMaj = Trim(s)
End Function

 

[Compte Supprimé 979]

Re : Une sympathique fonction pour taper Prénom + Nom

Salut MAGIC_DOCTOR,

Merci pour ton petit code, moi je connaissais la fonction : =NOMPROPRE()

Mais, il est vrai que pour les espaces en trop ça ne traitait rien

Pourquoi pas ...

 

[fred65200]

Re : Une sympathique fonction pour taper Prénom + Nom

bonsoir
une petite modification peut être,.

plutôt que d'avoir une condition interminable, pourquoi ne pas mettre les particules dans un tableau et de vérifier si ce "morceau" fait parti de tableau

Dim tabParticules As Variant
tabParticules = Array("de", "del", "la", "las", "los", "da", "do", "di", "van", "von", "der")
Morceaux = Split(np, " ")
For i = LBound(Morceaux) To UBound(Morceaux)

If Not IsError(Application.Match(Morceaux(i), tabParticules, 0)) Then

'If Morceaux(i) = "de" Or Morceaux(i) = "del" Or Morceaux(i) = "la" Or _ Morceaux(i) = "las" Or 'Morceaux(i) = "los" Or Morceaux(i) = "da" Or _ Morceaux(i) = "do" Or Morceaux(i) = "di" Or 'Morceaux(i) = "van" Or _ Morceaux(i) = "von" Or Morceaux(i) = "der" Then

s = s & (Morceaux(i)) & " "

cordialement

 

[Magic_Doctor]

Re : Une sympathique fonction pour taper Prénom + Nom

Merci Fred pour ton conseil.
Le problème, c'est que je suis un bidouilleur en VBA...
En effet, c'est nettement plus élégant et clair, surtout si l'on veut aisément rajouter des exceptions orthographiques qui doivent rester en minuscule.
Si j'écris : MARIE-EMANUELLE DE LA MCINTOCHE, j'aurais : Marie-Emanuelle de la McIntoche
Espaces superflus seront supprimés et les majuscules respectées.

Voici donc la fonction revue et corrigée par tes soins :

Public Function FirstLetterMaj(Nom_Prénom As Range)

Dim Morceaux() As String, temp As String, EspacesDoubles As String
Dim i As Integer, np As String, s As String
Dim tabParticules As Variant

tabParticules = Array("de", "del", "la", "las", "los", "da", "do", "di", "van", "von", "der")

np = LCase(Nom_Prénom.Value)

EspacesDoubles = Chr(32) & Chr(32)
temp = Trim(np)
Do Until InStr(temp, EspacesDoubles) = 0
temp = Replace(temp, EspacesDoubles, Chr(32))
Loop

np = temp

Morceaux = Split(np, " ")
For i = LBound(Morceaux) To UBound(Morceaux)
If Not IsError(Application.Match(Morceaux(i), tabParticules, 0)) Then
s = s & (Morceaux(i)) & " "
ElseIf Left(Morceaux(i), 2) = "mc" Then
Morceaux(i) = "Mc" & UCase(Mid(Morceaux(i), 3, 1)) & Right(Morceaux(i), Len(Morceaux(i)) - 3)
s = s & (Morceaux(i)) & " "
Else
s = s & WorksheetFunction.Proper(Morceaux(i)) & " "
End If
Next
FirstLetterMaj = Trim(s)
End Function