VBA excel hauteur de ligne homogène [débutant] [Résolu]

Signaler
Messages postés
5
Date d'inscription
vendredi 18 juin 2010
Statut
Membre
Dernière intervention
30 décembre 2011
-
Messages postés
5
Date d'inscription
vendredi 18 juin 2010
Statut
Membre
Dernière intervention
30 décembre 2011
-
Bonjour,
je souhaite faire une fonction qui semble facile...
Dans une cellule excel, je souhaite déterminer (filtrer) le nombre de retour chariot (Chr(10))afin d'augmenter ou de diminuer la hauteur de la ligne entière (Rowheight) de la cellule.

[*] la cellule appartient toujour à la collonne B
[*] La hauteur de la ligne doit être un multiple de 12.75 pour 0 Chr(10), de 25.5 pour 1 Chr(10), de 38.25 pour 3 Chr(10), etc etc...

Donc mon code :
détermine la zone des cellules concernées
sur chaque cellule un filtre s'applique pour rechercher les éventuels Chr(10)
On multiplie le nombre trouvé par 12.75
on applique la hauteur de la ligne concernée.

Ce qui me pose problème :
...
For a = 1 To nbrligne [détermine la zone]
textecellule = ActiveSheet.Range("B" & a) [permet de récupérer la valeur d'une cellule de la zone]
retourchariot = Filter(textecellule, Chr(10), True)[erreur]
...


A votre avis, la fonction filter est elle la mieux adapté?
Et existe t'il déja un code?

Merci d'avance

6 réponses

Messages postés
33003
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
21 juin 2021
351
Bonjour,

Essayes ce code là :

Sub test_chr()
Dim TexteCell As String
nblignes = 10 ; Nb lignes max à traiter.

For a = 1 To nblignes
    TexteCell = Range("B" & a).Value ' recuperation du texte
    nbChr = CountOccu(TexteCell, Chr(10))
    Debug.Print nbChr
Next

End Sub



Public Function CountOccu(ByRef vsInput As String, ByRef vsPattern As String, Optional ByVal veCompare As VbCompareMethod = vbBinaryCompare) As Integer
Dim i As Long
    i = InStr(1, vsInput, vsPattern, veCompare)
    Do While i
        CountOccu = CountOccu + 1
        i = InStr(i + 1, vsInput, vsPattern, veCompare)
    Loop
    
End Function




Ne reste plus qu'à l'adapter à tes besoins

Cordialement,
Jordane,
______________________________________________________
Règles du forum à lire avant de poster une question : ICI
Messages postés
33003
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
21 juin 2021
351
Hello,

Pas besoin de remettre une boucle.
Tu peux directement faire ta multiplication à la suite de la récupération du nombre de retours chariots.


Avec ce code..ça marche:
Sub Redim_chr()
Dim TexteCell As String
nblignes = 10 ' Nb lignes max à traiter.

For a = 1 To nblignes
    TexteCell = Range("B" & a).Value ' recuperation du texte
    'Nb de retours chariots dans la cellule :
    nbChr = CountOccu(TexteCell, Chr(10))
        Debug.Print nbChr
    
        
    'Taille à mettre sur la ligne :
    Nouvelle_Taille = nbChr * 12.75 + 12.75
        Debug.Print Nouvelle_Taille
    
    'Application de la taille dans la ligne (a) :
    ActiveSheet.Rows(a).RowHeight = Nouvelle_Taille
    
    
Next

End Sub



Public Function CountOccu(ByRef vsInput As String, ByRef vsPattern As String, Optional ByVal veCompare As VbCompareMethod = vbBinaryCompare) As Integer
Dim i As Long
    i = InStr(1, vsInput, vsPattern, veCompare)
    Do While i
        CountOccu = CountOccu + 1
        i = InStr(i + 1, vsInput, vsPattern, veCompare)
    Loop
    
End Function



PS : Utilises les balises de code lorsque tu copie du code dans le forum. (3eme icone en partant de la droite dans la barre d'outils )


Cordialement,
Jordane,
______________________________________________________
Règles du forum à lire avant de poster une question : ICI
Messages postés
33003
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
21 juin 2021
351
Et pour gagner du temps dans le traitement, désactive l'affichage pendant le traitement.

Application.ScreenUpdating = False


puis remets le à TRUE à la fin de ton traitement.
tu verras...ça va beaucoup plus vite

Cordialement,
Jordane,
______________________________________________________
Règles du forum à lire avant de poster une question : ICI
Messages postés
5
Date d'inscription
vendredi 18 juin 2010
Statut
Membre
Dernière intervention
30 décembre 2011

Salut Jordane et merci pour ta réponse
Je comprends la première partie du code (fonction test_Chr), qui marche super, le nombre de retour Chariot et juste,en plus elle est optimisée,

De plus j'ai appris l'utilité d'une fonction publique

par contre, si je veux muliplier le nombre de "Chr10" de chaque case controlées par 12.75 (hauteur de ligne), dois je y mettre dans la boucle "For a =1 to ..."

Pour que le programme décompte les Chr et tout de suite il adapte le Rowheight?

With ThisWorkbook.ActiveSheet
lastcell = ActiveSheet.Range("B10000").End(xlUp).Row
nbrlignes = lastcell ' Nb lignes max à traiter.
For a = 1 To nbrlignes
TexteCell = ActiveSheet.Range("B" & a).Value ' recuperation du texte
nbChr = CountOccu(TexteCell, Chr(10))
ActiveSheet.Range("B" & a).Select
Debug.Print nbChr

For b = 1 To nbChr
ActiveSheet.Range("B" & a).RowHeight = ActiveSheet.Range("B" & a).RowHeight * 12.75 'rien ne se passe
Next b

Next a

End With

End Sub
Public Function CountOccu(ByRef vsInput As String, ByRef vsPattern As String, Optional ByVal veCompare As VbCompareMethod = vbBinaryCompare) As Integer

Dim i As Long
vsInput = 10


i = InStr(1, vsInput, vsPattern, veCompare)
Do While i
CountOccu = CountOccu + 1
i = InStr(i + 1, vsInput, vsPattern, veCompare)
Loop

End Function


Dans tous les cas, je valide ta réponse merci.
Messages postés
5
Date d'inscription
vendredi 18 juin 2010
Statut
Membre
Dernière intervention
30 décembre 2011

Re.-
Oui bien sur, très bien comme ça



Private Sub CommandButton9_Click()
Dim nbrlignes
Dim a
Dim nbChr
Dim TexteCellule As String
Dim lastcell
Dim tailleligne


With ThisWorkbook.ActiveSheet
lastcell = ActiveSheet.Range("B1000").End(xlUp).Row
nbrlignes = lastcell ' Nb lignes max à traiter.

For a = 1 To nbrlignes

TexteCellule = Range("B" & a).Value ' recuperation du texte

nbChr = CountOccu(TexteCellule, Chr(10))
tailleligne = 12.75 + 12.75 * (nbChr)
Range("B" & a).RowHeight = tailleligne
Debug.Print nbChr

Next a

End With

End Sub
Public Function CountOccu(ByRef vsInput As String, ByRef vsPattern As String, Optional ByVal veCompare As VbCompareMethod = vbBinaryCompare) As Integer

Dim i As Long



    i = InStr(1, vsInput, vsPattern, veCompare)
    Do While i
        CountOccu = CountOccu + 1
        i = InStr(i + 1, vsInput, vsPattern, veCompare)
    Loop
    
End Function




Bon, ça ralentit pas mal le process, mais après tout c'est le PC travaille

Maintenant détection de modif sur feuille excel, mais ça c'est un autre post.
Merci de ton aide, jordane
Cordialement.
Messages postés
5
Date d'inscription
vendredi 18 juin 2010
Statut
Membre
Dernière intervention
30 décembre 2011

[^^sad2]