XL 2013 extraire les premières lettres d'une chaine de caractère

kabamel · 30 Août 2016

Salut à tous, comme dans le titre, J'ai besoin avec une fonction d'extraire les premières lettres d'une chaine dans une cellule. Mais les mots : "DES"; "DE"; "DU"; "D'"; "LES"; "LE"; "L'" et autres caractères comme "&" ne font pas partie. Par exemple : "Société d'Extraction de pétrole français" il m'envoie "SEPF". Merci pour aide.

Yurperqod · 30 Août 2016

Bonjour le forum

Un essai en formule avec 3 colonnes
en A1
Société d'Extraction de pétrole français
en B1

Code:

=SUBSTITUE(SUBSTITUE(A1;"d'";"");"de";"")

en C1

Code:

=MAJUSCULE(SUBSTITUE(GAUCHE(B1)&STXT(B1;TROUVE("$";SUBSTITUE(B1&"  ";" ";"$";1))+1;1)&STXT(B1;TROUVE("$";SUBSTITUE(B1&"  ";" ";"$";2))+1;1)&STXT(B1;TROUVE("$";SUBSTITUE(B1&"  ";" ";"$";3))+1;1)&STXT(B1;TROUVE("$";SUBSTITUE(B1&"  ";" ";"$";4))+1;1);" ";""))

La formule en C1 renvoie SEPF

Jacky67 · 30 Août 2016

kabamel à dit:
Salut à tous, comme dans le titre, J'ai besoin avec une fonction d'extraire les premières lettres d'une chaine dans une cellule.

Bonjour,
A tester...une fonction perso...

VB:

Function Sigle(Y As Range) As String
    Dim X As String, A As String, i As Long
    X = Y.Value
    X = Replace(X, " du ", " ")
    X = Replace(X, "Du ", " ")
    X = Replace(X, " de ", " ")
    X = Replace(X, "De ", "")
    X = Replace(X, " des ", " ")
    X = Replace(X, "Des ", " ")
    X = Replace(X, " les ", " ")
    X = Replace(X, "Les ", " ")
    X = Replace(X, " le ", " ")
    X = Replace(X, "Le ", " ")
    X = Replace(X, " la ", " ")
    X = Replace(X, "La ", " ")
    X = Replace(X, " l'", " ")
    X = Replace(X, "L'", "")
    X = Replace(X, " d'", " ")
    X = Replace(X, "D'", "")
    X = Replace(X, "$", "")
    X = Replace(X, "@", "")
    X = Replace(X, "&", "")
    If Left(X, 1) <> " " Then X = " " & X
    X = Replace(X, "££", "£")
    X = Replace(X, " ", "£")

    For i = 1 To Len(X)
        If Mid(X, i, 1) = "£" Then A = A & Mid(X, i + 1, 1)
    Next
    Sigle = UCase(A)
End Function

Liste non exhaustive

Un peu plus....en PJ
Re...PJ remplacée

kabamel · 31 Août 2016

Salut, Merci pour vos réponse, ça marche.

Modeste geedee · 31 Août 2016

Bonsour®

Jacky67 à dit:
Bonjour,
A tester...une fonction perso...
Un peu plus....en PJ

alors une peu plus exhaustive...
A noter que la règle entre sigles et acronymes est élastique ...
reste également à voir le traitement des lettres Accentuées
http://www.senat.fr/histoire/sigles.html

Jacky67 · 31 Août 2016

Modeste geedee à dit:
Bonsour®
alors une peu plus exhaustive...
A noter que la règle entre sigles et acronymes est élastique ...
reste également à voir le traitement des lettres Accentuées
http://www.senat.fr/histoire/sigles.html

Bonjour Modeste
Manque encore le "Ou"
Merci de m'avoir rappeler la fonction "Trim()" que j'ai tendance à oublier.

Bonne journée

Modeste geedee · 31 Août 2016

OUPSSSS...

Modeste geedee · 31 Août 2016

Bonsour®

Jacky67 à dit:
Bonjour Modeste
Manque encore le "Ou"
Merci de m'avoir rappeler la fonction "Trim()" que j'ai tendance à oublier.

il conviendra toutefois de différencier la fonction VBA TRIM de la WorkSheetFunction.Trim qui ont des comportements différents.
VBA Trim : seule suppression des espaces précédents et suivants
WSF.Trim : suppression des espaces précédents et suivants + réduction à un seul des espaces redondants intérieurs

VB:

Function Sigle(Y As Range) As String
    Dim X As String, A As String, i As Long
    X = Application.Proper(Y.Value)
  ' ---------------------------------- articles , conjonctions et sigles superfétatoires
    X = Replace(X, "$", " ")
    X = Replace(X, "@", " ")
    X = Replace(X, "&", " ")
    X = Replace(X, "(", " ")
    X = Replace(X, ")", " ")
    X = Replace(X, ".", " ")
    X = Replace(X, "-", " ")
    X = Replace(X, "D'", " ")
    X = Replace(X, "Du ", " ")
    X = Replace(X, "De ", " ")
    X = Replace(X, "Des ", " ")
    X = Replace(X, "Les ", " ")
    X = Replace(X, "Le ", " ")
    X = Replace(X, "La ", " ")
    X = Replace(X, "L'", " ")
    X = Replace(X, "Et ", " ")
    X = Replace(X, " Of ", " ")
    X = Replace(X, " Pour ", " ")
    X = Replace(X, " À ", " ")
    X = Replace(X, " Au ", " ")
    X = Replace(X, " Aux ", " ")
    X = Replace(X, " En ", " ")
    X = Replace(X, " Ou ", " ")
    X = Replace(X, " Un ", " ")
    X = Replace(X, " Une ", " ")
    X = Replace(X, " Par ", " ")
    ' ----------------------------suppression espaces redondants
    X = " " & WorksheetFunction.Trim(X)
    ' ----------------------------recupération initiales
    For i = 1 To Len(X)
        If Mid(X, i, 1) = " " Then A = A & Mid(X, i + 1, 1)
    Next
    Sigle = SansAccent(A)
End Function
Function SansAccent(texte)
'Définition des variables
     avec = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç_"
     sans = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc "
     tmp = texte
'Boucle de traitement
     For i = 1 To Len(tmp)
         pot = InStr(avec, Mid(tmp, i, 1))
         If pot > 0 Then Mid(tmp, i, 1) = Mid(sans, pot, 1)
     Next i
     If tmp = 0 Then tmp = ""
     SansAccent = tmp
End Function

Jacky67 · 31 Août 2016

Modeste geedee à dit:

Bonsour®
il conviendra toutefois de différencier la fonction VBA TRIM de la WorkSheetFunction.Trim qui ont des comportements différents.
VBA Trim : seule suppression des espaces précédents et suivants
WSF.Trim : suppression des espaces précédents et suivants + réduction à un seul des espaces redondants intérieurs

VB:

Function Sigle(Y As Range) As String
    Dim X As String, A As String, i As Long
    X = Application.Proper(Y.Value)
  ' ---------------------------------- articles , conjonctions et sigles superfétatoires
    X = Replace(X, "$", " ")
    X = Replace(X, "@", " ")
    X = Replace(X, "&", " ")
    X = Replace(X, "(", " ")
    X = Replace(X, ")", " ")
    X = Replace(X, ".", " ")
    X = Replace(X, "-", " ")
    X = Replace(X, "D'", " ")
    X = Replace(X, "Du ", " ")
    X = Replace(X, "De ", " ")
    X = Replace(X, "Des ", " ")
    X = Replace(X, "Les ", " ")
    X = Replace(X, "Le ", " ")
    X = Replace(X, "La ", " ")
    X = Replace(X, "L'", " ")
    X = Replace(X, "Et ", " ")
    X = Replace(X, " Of ", " ")
    X = Replace(X, " Pour ", " ")
    X = Replace(X, " À ", " ")
    X = Replace(X, " Au ", " ")
    X = Replace(X, " Aux ", " ")
    X = Replace(X, " En ", " ")
    X = Replace(X, " Ou ", " ")
    X = Replace(X, " Un ", " ")
    X = Replace(X, " Une ", " ")
    X = Replace(X, " Par ", " ")
    ' ----------------------------suppression espaces redondants
    X = " " & WorksheetFunction.Trim(X)
    ' ----------------------------recupération initiales
    For i = 1 To Len(X)
        If Mid(X, i, 1) = " " Then A = A & Mid(X, i + 1, 1)
    Next
    Sigle = SansAccent(A)
End Function
Function SansAccent(texte)
'Définition des variables
     avec = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç_"
     sans = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc "
     tmp = texte
'Boucle de traitement
     For i = 1 To Len(tmp)
         pot = InStr(avec, Mid(tmp, i, 1))
         If pot > 0 Then Mid(tmp, i, 1) = Mid(sans, pot, 1)
     Next i
     If tmp = 0 Then tmp = ""
     SansAccent = tmp
End Function

RE...
Pas mal tout y est...presque, reste les chiffres
A quoi sert ,
If TMP = 0 Then TMP = ""
?

Lone-wolf · 31 Août 2016

Bonsoir à tous

Pourquoi ne pas utiliser un tableau Array , moins de remplacement à faire non?

VB:

Txt = Array("$", "@", "&", "/", "\", "(", ")", ".", "-", " D' ",  _
" Du ", " De ", " Des ", " L' ",  " Le ", " Les ", " La ", " Et ",  _
" Ou ", " Of ", " Pour ", " À ", " Au ", " Aux ", " En ",  "pour", "l'")
 
  For k = LBound(Txt) To UBound(Txt)
  X = Replace(X, Txt(k), " ")
  Next k

Jacky67 · 31 Août 2016

Lone-wolf à dit:
Bonsoir à tous

Pourquoi ne pas utiliser un tableau Array , moins de remplacement à faire non?

Bonsoir Lone-wolf,
Oui, j'y avais pensé, mais je trouvais " le visuel" plus pratique avec les "Replace",
surtout, que, comme c'est parti, la liste s'allonge
Et ma vue baisse

Bonne soirée

XL 2013 extraire les premières lettres d'une chaine de caractère

kabamel

XLDnaute Occasionnel

Yurperqod

XLDnaute Occasionnel

Jacky67

XLDnaute Barbatruc

Pièces jointes

kabamel

XLDnaute Occasionnel

Modeste geedee

XLDnaute Barbatruc

Pièces jointes

Jacky67

XLDnaute Barbatruc

Modeste geedee

XLDnaute Barbatruc

Modeste geedee

XLDnaute Barbatruc

Jacky67

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Jacky67

XLDnaute Barbatruc

Discussions similaires