[VBA] Changement de la casse dans une cellule

flipflip

XLDnaute Nouveau
Bonjour, pour automatiser le traitement de donnée je dois faire en sorte de modifier la casse de certains caractères suivant des conditions :
- Première lettre de la cellule en majuscule;
- Première lettre après un point en majuscule;
- Première lettre après un point et un espace en majuscule;
- Première lettre après un point et un retour chariot en majuscule;
- Première lettre après un point, un espace, un retour chariot en majuscule;
- Première lettre après un retour chariot en majuscule.

J'ai réussi à coder un truc pour les 3 premiers cas mais pour rajouter les autres c'est la galère.
Est-ce que vous avez une idée ?
 

flipflip

XLDnaute Nouveau
Re : [VBA] Changement de la casse dans une cellule

OUai effectivement, mais en fait ça fait 5à fois que je retourne le truc dans tout les sens. Pour le moment j'en suis à ça mais c'est pas très optimisé :
Code:
Sub FirstMaj()
    ' Permet la mise en majuscule de la première lettre d'une phrase
    ' et le reste en minuscule. Si la phrase contient un "." alors la
    ' première lettre du mot suivant sera en majuscule
    Dim Plage As Range, Cellule As Range
    Dim Chaine, ChaineLeft, ChaineRight, ChaineTmp As String
    Dim y As Integer
   
    ' Active la gestion des erreurs
    On Error GoTo Erreur
    
    ' Affiche une fenêtre pour choisir la plage ou la cellule
    Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)
    
    For Each Cellule In Plage
        ' Applique les modifications que
        ' sur les cellules non vides
        If Cellule.Value <> "" Then
            ' Sélectionne la cellule en cours
            Range(Cellule.Address).Select
            Chaine = ActiveCell.Value
            
            ' Longueur total de la chaîne
            TotalLen = Len(Chaine)
            
            ' Met la premiere lettre en majuscule
            ChaineLeft = UCase(Left(Chaine, 1))
            ChaineRight = LCase(Right(Chaine, TotalLen - 1))
            Chaine = ChaineLeft & ChaineRight
            
            y = 1
            While TotalLen <> y
                ' Extrait chaque caractère pour tester
                ' la valeur
                Char = Mid(Chaine, y, 1)
                If Char = "." Then
                    Position = InStr(y, Chaine, Char)
                    ChaineTmp = UCase(Mid(Chaine, Position + 1, 1))
                End If
                                        
                ' Nombre de caractères pour la droite de la chaine
                NbChaineRight = TotalLen - Position
                MsgBox (NbChaineRight)
                ChaineRight = Right(Chaine, NbChaineRight)
                
                ' Nombre de caractères pour la gauche de la chaine
                NbChaineLeft = TotalLen - NbChaineRight
                ChaineLeft = Left(Chaine, NbChaineLeft)

                ' Modification de la casse du caractère après le .
                'ChaineTmp = UCase(Mid(Chaine, Position_1 + 1, 1))
                    
                ' Recréation de la valeur de la cellule
                Chaine = ChaineLeft & ChaineTmp & ChaineRight
                ActiveCell.Value = Chaine
                y = y + 1
            Wend
            ' Modifie la valeur de la cellule courante
            'ActiveCell.Value = Chaine
        End If
    Next Cellule
Exit Sub

Erreur:
    If err.Number = 424 Then
        MsgBox ("La transformation n'a pas pu se faire")
    End If
End Sub
 

Luki

XLDnaute Accro
Re : [VBA] Changement de la casse dans une cellule

Re,

Un essai en vba avec gestion d'une cellule commençant par un des caractères spéciaux et pour une chaîne de longueur de 1 caractère. Ca travaille sur la cellule active. Je te laisse l'adapter à ton cas.

Fais des test et dis nous.

Code:
Option Explicit
Sub UcaseProc()
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft As Integer

    Str1 = ActiveCell.Text
    'passe toute la chaîne en minuscule
    Str1 = LCase(Str1)
    'compte la longueur
    LongStr = Len(Str1)
    'Si chaîne de longueur 1, alors saute à la fin de procédure
    If LongStr = 1 Then GoTo PremierCaractere
    
    ' boucle à partir de la droite jusqu'au 2ème caractère
    For i = LongStr To 2 Step -1
        'sort le code du car actif
        iCar = Asc(Mid(Str1, i, 1))
        'sort le code du car à gauche du car actif
        icarLeft = Asc(Mid(Str1, i - 1, 1))
        'Si le car actif n'est pas un des 3,alors
        If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
            'Si le car à gauche est un des 3, alors passe le car actif en majuscule
            If icarLeft = 10 Or icarLeft = 32 Or icarLeft = 46 Then
                TempStr = UCase(Chr(iCar))
            Else
            'sinon le laisse en minuscule
                TempStr = Chr(iCar)
            End If
        Else
            'sinon le laisse en minuscule
            TempStr = Chr(iCar)
        End If
        
    'ajoute le car trouvé à la chaîne
    Str2 = Str2 & TempStr
    Next i
    
'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If
    
Str2 = Str2 & TempStr
'inversion de la chaîne trouvée
Str2 = StrReverse(Str2)
'renvoi de la valeur dans la cellule
ActiveCell.Value = Str2

End Sub
A te lire
 

Luki

XLDnaute Accro
Re : [VBA] Changement de la casse dans une cellule

Re,

Version corrigée (les espaces étaient mal gérés). :eek:

Code:
Option Explicit

Sub UcaseProc()
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft1 As Integer, icarLeft2 As Integer
    Str1 = ActiveCell.Text
    'passe toute la chaîne en minuscule
    Str1 = LCase(Str1)
    'compte la longueur
    LongStr = Len(Str1)
    'Si la chaîne est vide, sortie
    If LongStr = 0 Then Exit Sub
    'Si chaîne de longueur 1, alors saute à la fin de procédure
    If LongStr = 1 Then GoTo PremierCaractere
    
    ' boucle à partir de la droite jusqu'au 2ème caractère
    For i = LongStr To 3 Step -1
        'sort le code du car actif
        iCar = Asc(Mid(Str1, i, 1))
        'sort le code du car à gauche du car actif
        icarLeft1 = Asc(Mid(Str1, i - 1, 1))
        'sort le code du 2ème car à gauche du car actif
        icarLeft2 = Asc(Mid(Str1, i - 2, 1))
        'Si le car actif n'est pas un des 3,alors
        If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
            'Si le car à gauche est un point, alors passe le car actif en majuscule
            If icarLeft1 = 46 Then
                TempStr = UCase(Chr(iCar))
            'si point et espace,alors majuscule
            ElseIf icarLeft1 = 32 And icarLeft2 = 46 Then
                TempStr = UCase(Chr(iCar))
            'si retour chariot, alors majuscule
            ElseIf icarLeft1 = 10 Then
                TempStr = UCase(Chr(iCar))
            'sinon le laisse en minuscule
            Else
                TempStr = Chr(iCar)
            End If
        Else
            'sinon le laisse en minuscule
            TempStr = Chr(iCar)
        End If
        
    'ajoute le car trouvé à la chaîne
    Str2 = Str2 & TempStr
    Next i
    
'gestion du caractère 2
SecondCaractere:
    iCar = Asc(Mid(Str1, 2, 1))
    icarLeft1 = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        If icarLeft1 = 10 Or icarLeft1 = 46 Then
            TempStr = UCase(Chr(iCar))
        Else
            TempStr = Chr(iCar)
        End If
    Else
        TempStr = Chr(iCar)
    End If
    
Str2 = Str2 & TempStr
'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If
Str2 = Str2 & TempStr

'inversion de la chaîne trouvée
Str2 = StrReverse(Str2)
'renvoi de la valeur dans la cellule
ActiveCell.Value = Str2

End Sub
 

flipflip

XLDnaute Nouveau
Re : [VBA] Changement de la casse dans une cellule

Bonjour, merci pour le code.
Je l'ai adapté mais je n'arrive pas à le faire fonctionner correctement. En fait il cumul toute les valeurs dans la variable Str2 et ensuite écrit le contenue de cette variable dans la dernière cellule de ma plage sélectionné.
Code:
' Module regroupant différent outils
Option Explicit

Sub FirstMaj()
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft1 As Integer, icarLeft2 As Integer
Dim Plage As Range, Cellule As Range

    ' Active la gestion des erreurs
    On Error GoTo Erreur
    
    ' Affiche une fenêtre pour choisir la plage ou la cellule
    Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)
    
    For Each Cellule In Plage
        ' Sélectionne la cellule en cours
        Range(Cellule.Address).Select
        Str1 = ActiveCell.Text
                       
        'compte la longueur
        LongStr = Len(Str1)
            
        'Si la chaîne est vide, sortie
        If LongStr = 0 Then Exit Sub
            
        'Si chaîne de longueur 1, alors saute à la fin de procédure
        If LongStr = 1 Then GoTo PremierCaractere
        
        'passe toute la chaîne en minuscule
        Str1 = LCase(Str1)
    
        ' boucle à partir de la droite jusqu'au 2ème caractère
        For i = LongStr To 3 Step -1
            'sort le code du car actif
            iCar = Asc(Mid(Str1, i, 1))
                
            'sort le code du car à gauche du car actif
            icarLeft1 = Asc(Mid(Str1, i - 1, 1))
                
            ' sort le code du 2ème car à gauche du car actif
            icarLeft2 = Asc(Mid(Str1, i - 2, 1))
                
            'Si le car actif n'est pas un des 3,alors
            If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
                'Si le car à gauche est un point, alors passe le car actif en majuscule
                If icarLeft1 = 46 Then
                    TempStr = UCase(Chr(iCar))
                'si point et espace, alors majuscule
                ElseIf icarLeft1 = 32 And icarLeft2 = 46 Then
                    TempStr = UCase(Chr(iCar))
                'si retour chariot, alors majuscule
                ElseIf icarLeft1 = 10 Then
                    TempStr = UCase(Chr(iCar))
                        
                'sinon le laisse en minuscule
                Else
                    TempStr = Chr(iCar)
                End If
            Else
                'sinon le laisse en minuscule
                TempStr = Chr(iCar)
            End If
        
            'ajoute le car trouvé à la chaîne
            Str2 = Str2 & TempStr
        Next i
    Next Cellule
    
'gestion du caractère 2
SecondCaractere:
    iCar = Asc(Mid(Str1, 2, 1))
    icarLeft1 = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        If icarLeft1 = 10 Or icarLeft1 = 46 Then
            TempStr = UCase(Chr(iCar))
        Else
            TempStr = Chr(iCar)
        End If
    Else
        TempStr = Chr(iCar)
    End If
        Str2 = Str2 & TempStr
        
'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If
    
    Str2 = Str2 & TempStr

    'inversion de la chaîne trouvée
    Str2 = StrReverse(Str2)
    
    'renvoi de la valeur dans la cellule
    ActiveCell.Value = Str2
Exit Sub

'Next Cellule

Erreur:
    If err.Number = 424 Then
        'MsgBox ("La transformation n'a pas pu se faire")
    End If
End Sub
 

Luki

XLDnaute Accro
Re : [VBA] Changement de la casse dans une cellule

bonjout flipflip

essaie les corrections ci-dessous:

Code:
' Module regroupant différent outils
Option Explicit

Sub FirstMaj()
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft1 As Integer, icarLeft2 As Integer
Dim Plage As Range, Cellule As Range

    ' Active la gestion des erreurs
'''    'On Error GoTo Erreur il ne devrait pas y avoir d'erreur à gérer
    
    ' Affiche une fenêtre pour choisir la plage ou la cellule
    Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)
    
    For Each Cellule In Plage
        ' Sélectionne la cellule en cours
        'inutile>> Range(Cellule.Address).Select
       
        Str1 = Cellule.Text
         'vidage des variables
        Str2 = ""
        TempStr = ""
                       
        'compte la longueur
        LongStr = Len(Str1)
            
        'Si la chaîne est vide, sortie
        If LongStr = 0 Then Exit Sub
            
        'Si chaîne de longueur 1, alors saute à la fin de procédure
        If LongStr = 1 Then GoTo PremierCaractere
        
        'passe toute la chaîne en minuscule
        Str1 = LCase(Str1)
    
        ' boucle à partir de la droite jusqu'au 2ème caractère
        For i = LongStr To 3 Step -1
            'sort le code du car actif
            iCar = Asc(Mid(Str1, i, 1))
                
            'sort le code du car à gauche du car actif
            icarLeft1 = Asc(Mid(Str1, i - 1, 1))
                
            ' sort le code du 2ème car à gauche du car actif
            icarLeft2 = Asc(Mid(Str1, i - 2, 1))
                
            'Si le car actif n'est pas un des 3,alors
            If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
                'Si le car à gauche est un point, alors passe le car actif en majuscule
                If icarLeft1 = 46 Then
                    TempStr = UCase(Chr(iCar))
                'si point et espace, alors majuscule
                ElseIf icarLeft1 = 32 And icarLeft2 = 46 Then
                    TempStr = UCase(Chr(iCar))
                'si retour chariot, alors majuscule
                ElseIf icarLeft1 = 10 Then
                    TempStr = UCase(Chr(iCar))
                        
                'sinon le laisse en minuscule
                Else
                    TempStr = Chr(iCar)
                End If
            Else
                'sinon le laisse en minuscule
                TempStr = Chr(iCar)
            End If
        
            'ajoute le car trouvé à la chaîne
            Str2 = Str2 & TempStr
        Next i

    
'gestion du caractère 2
SecondCaractere:
    iCar = Asc(Mid(Str1, 2, 1))
    icarLeft1 = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        If icarLeft1 = 10 Or icarLeft1 = 46 Then
            TempStr = UCase(Chr(iCar))
        Else
            TempStr = Chr(iCar)
        End If
    Else
        TempStr = Chr(iCar)
    End If
        Str2 = Str2 & TempStr
        
'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If
    
    Str2 = Str2 & TempStr

    'inversion de la chaîne trouvée
    Str2 = StrReverse(Str2)
    
    'renvoi de la valeur dans la cellule traitée, pas la cellule active
    Cellule = Str2


Next Cellule ' ta première idée était la bonne!

'''Exit Sub
'''Erreur:
'''    If Err.Number = 424 Then
'''        'MsgBox ("La transformation n'a pas pu se faire")
'''    End If
End Sub

Fais des essais et dis nous. il y auar peutêtre un pb sur des cellules de 2 caractères, pas eu le temps de tester!

Pas dispo avant 2 jours...

A+
 

flipflip

XLDnaute Nouveau
Re : [VBA] Changement de la casse dans une cellule

Salut et bonne année. Désolé pour le temps de réponse.
J'ai testé avec tes petites modif et c'est parfait, merci.

Edit : Je viens de me rendre compte d'un petit soucis. Si dans la plage sélectionné une cellule est vide la macro s'arrête sans erreur.

Philippe.
 
Dernière édition:

flipflip

XLDnaute Nouveau
Re : [VBA] Changement de la casse dans une cellule

J'ai creusé un peu et c'est la ligne
Code:
        If LongStr = 0 Then Exit Sub
Bien sur si je l'enlève ça ne marche plus puisqu'il essai de me modifier des valeurs vide. Le truc serait de lui dire de passer à la cellule suivante (Next Cellule comme à la fin du for) mais je ne sais pas trop comment faire.
 

Luki

XLDnaute Accro
Re : [VBA] Changement de la casse dans une cellule

bonjour flipflip, chti,

sinon, utilise la macro comme fonction et intègre la dans ta boucle (cette macro était faite pour ne travailler que sur la cellule active, comme précisé plus haut):

la macro


Code:
Sub FirstMaj()
    ' Permet la mise en majuscule de la première lettre d'une phrase
    ' et le reste en minuscule. Si la phrase contient un "." alors la
    ' première lettre du mot suivant sera en majuscule
    Dim Plage As Range, Cellule As Range
   
    
    ' Affiche une fenêtre pour choisir la plage ou la cellule
    Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)
    
    For Each Cellule In Plage
    Cellule = F_Ucase(Cellule.Text)
    Next Cellule
End Sub
et la fonction utilisée par la macro
Code:
Function F_Ucase(Texte As String) As String
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft As Integer
Application.Volatile
    Str1 = Texte
    'passe toute la chaîne en minuscule
    Str1 = LCase(Str1)
    'compte la longueur
    LongStr = Len(Str1)
    'compte la longueur
    LongStr = Len(Str1)
    'Si la chaîne est vide, sortie
    If LongStr = 0 Then Exit Function
    'Si chaîne de longueur 1, alors saute à la fin de procédure
    If LongStr = 1 Then GoTo PremierCaractere
    
    ' boucle à partir de la droite jusqu'au 2ème caractère
    For i = LongStr To 2 Step -1
        'sort le code du car actif
        iCar = Asc(Mid(Str1, i, 1))
        'sort le code du car à gauche du car actif
        icarLeft = Asc(Mid(Str1, i - 1, 1))
        'Si le car actif n'est pas un des 3,alors
        If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
            'Si le car à gauche est un des 3, alors passe le car actif en majuscule
            If icarLeft = 10 Or icarLeft = 32 Or icarLeft = 46 Then
                TempStr = UCase(Chr(iCar))
            Else
            'sinon le laisse en minuscule
                TempStr = Chr(iCar)
            End If
        Else
            'sinon le laisse en minuscule
            TempStr = Chr(iCar)
        End If
        
    'ajoute le car trouvé à la chaîne
    Str2 = Str2 & TempStr
    Next i
    
'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If
    
Str2 = Str2 & TempStr
'inversion de la chaîne trouvée
Str2 = StrReverse(Str2)

'renvoi de la valeur par la fonction
F_Ucase = Str2
la fonction doit se trouver dans le même projet VBA que la macro

bonne journée :)
 

flipflip

XLDnaute Nouveau
Re : [VBA] Changement de la casse dans une cellule

Salut, merci Luki pour ton aide. Maintenant ça marche nikel.
Code:
' Module regroupant différent outils
Option Explicit

Sub FirstMaj()
' Permet la mise en majuscule de la première lettre d'une phrase
' et le reste en minuscule. Si la phrase contient un "." alors la
' première lettre du mot suivant sera en majuscule
Dim Plage As Range, Cellule As Range
    On Error GoTo Erreur
    
    ' Affiche une fenêtre pour choisir la plage ou la cellule
    Set Plage = Application.InputBox("Sélectionner une plage de cellules ou une cellule", "Sélection", Type:=8)
    
    For Each Cellule In Plage
        Cellule = F_Ucase(Cellule.Text)
    Next Cellule
    
Erreur:
    If err.Number = 424 Then Exit Sub
    
End Sub

Function F_Ucase(Texte As String) As String
Dim Str1 As String, Str2 As String, TempStr As String
Dim i As Integer, LongStr As Integer
Dim iCar As Integer, icarLeft1 As Integer, icarLeft2 As Integer
Application.Volatile
    
    ' Sélection de la cellule
    Str1 = Texte
    Str1 = LCase(Str1)
                       
    'compte la longueur
    LongStr = Len(Str1)
            
    'Si la chaîne est vide, sortie
    If LongStr = 0 Then Exit Function
            
    'Si chaîne de longueur 1, alors saute à la fin de procédure
    If LongStr = 1 Then GoTo PremierCaractere
    
    ' boucle à partir de la droite jusqu'au 2ème caractère
    For i = LongStr To 3 Step -1
        'sort le code du car actif
        iCar = Asc(Mid(Str1, i, 1))
                
        'sort le code du car à gauche du car actif
        icarLeft1 = Asc(Mid(Str1, i - 1, 1))
                
        ' sort le code du 2ème car à gauche du car actif
        icarLeft2 = Asc(Mid(Str1, i - 2, 1))
                
        'Si le car actif n'est pas un des 3,alors
        If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
            'Si le car à gauche est un point, alors passe le car actif en majuscule
            If icarLeft1 = 46 Then
                TempStr = UCase(Chr(iCar))
            'si point et espace, alors majuscule
            ElseIf icarLeft1 = 32 And icarLeft2 = 46 Then
                TempStr = UCase(Chr(iCar))
            'si retour chariot, alors majuscule
            ElseIf icarLeft1 = 10 Then
                TempStr = UCase(Chr(iCar))
                        
            'sinon le laisse en minuscule
            Else
                TempStr = Chr(iCar)
            End If
        Else
            'sinon le laisse en minuscule
            TempStr = Chr(iCar)
        End If
        
        'ajoute le car trouvé à la chaîne
        Str2 = Str2 & TempStr
    Next i
    
'gestion du caractère 2
SecondCaractere:
    iCar = Asc(Mid(Str1, 2, 1))
    icarLeft1 = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        If icarLeft1 = 10 Or icarLeft1 = 46 Then
            TempStr = UCase(Chr(iCar))
        Else
           TempStr = Chr(iCar)
        End If
   Else
       TempStr = Chr(iCar)
   End If
        Str2 = Str2 & TempStr

'gestion du premier caractère
PremierCaractere:
    iCar = Asc(Mid(Str1, 1, 1))
    If Not (iCar = 10 Or iCar = 32 Or iCar = 46) Then
        TempStr = UCase(Chr(iCar))
    Else
        TempStr = Chr(iCar)
    End If

    Str2 = Str2 & TempStr

    'inversion de la chaîne trouvée
    Str2 = StrReverse(Str2)

    'renvoi de la valeur dans la cellule
    F_Ucase = Str2
End Function
 

Discussions similaires

Statistiques des forums

Discussions
311 721
Messages
2 081 927
Membres
101 842
dernier inscrit
seb0390