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

Question

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

jordane45 · Accepted Answer

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

Merowig · Answer

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.

jordane45 · Answer

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

Merowig · Answer

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.

jordane45 · Answer

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

Merowig · Answer

[^^sad2]

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

6 réponses

Votre réponse

Discussions similaires