Bonjour,

Je dois créer un tableau, qui reprend les coordonnées de nombreuses personnes. Mon fichier doit être envoyé à différentes entités et aucune ne respecte les règles de remplissage que je lui demande (nom en majuscule, prénom avec la première lettre en majuscule et le reste en minuscule....).

En cherchant sur le site, j'ai trouvé comment forcer la saisie en majuscule avec la fonction éponyme et j'utilise également la fonction NOMPROPRE.

Toutefois, j'aimerais que dans le champ "Adresse" de mon tableau, il n’y ait pas de majuscules aux mots « rue », « avenue », etc., ni aux articles « du », « de », etc.

Une adresse doit donc ressembler à : 12 rue de la Paix et non pas 12 Rue De La Paix (que j’obtiens avec la fonction NOMPROPRE).

J’ai donc trouvé sur internet la fonction suivante :

Function NomPropre2(nom As String)

  temp = Application.Proper(nom)

  tbl = Array("De ", "Du ", "Des ", "Le ", "La ", "À ", "En ", "Au ", "Bis ", "Ter ", "D'", "L'", "Aux ", Rue ", "Avenue ", "Boulevard ", "Place ", "Allée ")

  For i = 0 To UBound(tbl)

    temp = Replace(temp, tbl(i), LCase(tbl(i)))

  Next i

  '---

  p = InStr(temp, "'")            ' position de '

  If p > 0 Then

    If Mid(temp, p - 2, 1) <> " " Then

      Mid(temp, p + 1, 1) = LCase(Mid(temp, p + 1, 1))

    End If

  End If

  NomPropre2 = temp

End Function

Cette fonction marche bien, mais pour cela je dois passer par une autre feuille, alors que les fonctions « MAJUSCULE » ou « NOMPROPRE » font la correction automatiquement dans la cellule que je complète.

Est-il possible de faire que la saisie soit corrigée automatiquement ? Je voudrais que le fichier que j’envoie ne comporte qu’un seul onglet.

J’espère que ma demande est claire et que vous connaissez un moyen de m’aider.

Je vous en remercie par avance.

Althéa

Bonsoir à tous
Bonsoir Althéa

Si j'ai bien compris ton problème, je te propose une Sub que tu lanceras une fois que tu auras tout "saisi".

Il te suffit de sélectionner les cellules (qui doivent être dans la même colonne) à vérifier et à lancer la procédure.

Option Explicit

Sub Maj_Min()
Dim tbl As String
Dim tbl_cellule As Variant
Dim tablo()
Dim a As Integer, i As Integer
Dim ma_cell As String
Dim ma_col As String
Dim derlign As Integer
Dim premlign As Integer

If ActiveCell = "" Then MsgBox "Sélectionner les cellules à corriger": Exit Sub
tablo = Array("De", "Du", "Des", "Le", "La", "À", "En", "Au", "Bis", "Ter", "D'", "L'", "Aux", "Rue", "Avenue", "Boulevard", "Place", "Allée")
tbl = Selection.AddressLocal(RowAbsolute:=False, ColumnAbsolute:=False)

premlign = Trim(Val(Mid(Split(tbl, ":")(0), 2, Len(Split(tbl, ":")(0)) - 2 + 1)))
If InStr(tbl, ":") <> 0 Then derlign = Val(Mid(Split(tbl, ":")(1), 2, Len(Split(tbl, ":")(1)) - 2 + 1)) Else derlign = premlign
ma_col = Mid(Split(tbl, ":")(0), 1, Len(Split(tbl, ":")(0)) - Len(CStr(premlign)))

For i = premlign To derlign
    tbl_cellule = Split(Range(ma_col & i), " ")
    For a = 0 To UBound(tbl_cellule, 1)
        If Not IsError(Application.Match(tbl_cellule(a), tablo, 0)) = True Then
            ma_cell = ma_cell & LCase(tbl_cellule(a)) & " "
        Else
            If a = 0 Then
                ma_cell = tbl_cellule(a) & " "
            Else
                ma_cell = ma_cell & tbl_cellule(a) & " "
            End If
        End If
    Next a
    Range(ma_col & i) = Trim(ma_cell)
    ma_cell = ""
Next i

End Sub

Dis nous 

Eric

Bonjour,

il y a plusieurs manières de traiter ton sujet.

Ci-joint une possibilité simple que tu devras améliorer, notamment en inscrivant dans la colonne A de la Feuille 2 les mots qui doivent être traités en minuscules.

Sub AdressePostale()
Dim PlMotsMin As Range, PlAdresses As Range
Dim Cel As Range, TabMots As Variant, Adresse
Dim i As Long, j As Long
Set PlMotsMin = Range("mots_min")
Set PlAdresses = Range("adresses")
j = 1
For Each Cel In PlAdresses
  Adresse = Application.WorksheetFunction.Trim(LCase(Cel.Text))
  TabMots = Split(Adresse)
  For i = LBound(TabMots) To UBound(TabMots)
    If Application.WorksheetFunction.CountIf(PlMotsMin, TabMots(i)) = 0 Then _
    TabMots(i) = Application.WorksheetFunction.Proper(TabMots(i))
  Next i
  PlAdresses(j).Offset(, 1) = Join(TabMots, " ")
  j = j + 1
Next Cel
End Sub

A+