Macro ajustement ht cellules fusionnées et hauteur minimale

[JULIANSAT]

Bonjour à tous

Je récupère des donnée en provenance CAO.
Sur une des feuilles du classeur Excel, je souhaite :
- Uniquement pour les cellules en dessous de la celllule A9
-Ht minimal des cellules 33 mm
- Ht ajusté pour les cellules contenant un texte long
Il y a des cellules fusionnées sur cette feuille.

J'ai repris un code du site pour l'adapter à mes besoins.
Pb, le code ci-après, traite aussi les cellules avant la ligne 10.
J'ai essayé de modifier le "For Each cel In ActiveSheet.UsedRange" sans succès.

Autre point, le traitement est long, plus écran instable.

Merci beaucoup.


Julian



****************************
Sub AjusteEnHauteur()
Sheets("Feuil1").Select
Range("A10:A500").Select
For Each cel In ActiveSheet.UsedRange
If cel <> "" Then
Set m = cel.MergeArea
m.UnMerge
m.WrapText = True
m.HorizontalAlignment = xlCenterAcrossSelection
m.Rows.AutoFit
m.Merge
End If
Next
For Each c In Rows("10:500")
If c.RowHeight < 33 Then c.RowHeight = 33
Next c
End Sub
*****************************

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

bonjour,

à tester:

Sub AjusteEnHauteur()

Sheets("Feuil1").Select
Range("A10:A500").Select
Application.ScreenUpdating = False

For Each Cel In Selection
    If Cel <> "" Then
        Set M = Cel.MergeArea
        M.UnMerge
        M.WrapText = True
        M.HorizontalAlignment = xlCenterAcrossSelection
        M.Rows = IIf(M.RowHeight < 33, 33, M.RowHeight)
        M.Merge
    End If
Next
Application.ScreenUpdating = True

End Sub

à+

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

Bonjour Francedemo.

Cela ne semble pas fonctionné ( je suis sur excel 2002).

Mon code fonctionne. Mais ne débute pas à partir de la ligne 10;

Merci


Julian

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

dans le code que je t'ai indiqué, il y a :

Range("A10:A500").Select
...
For Each Cel In Selection

ça signifie que le range A10:1500 est sélectionné
et qu'après, on travaille sur la sélection, donc de A10 à A500

tu dis que ça ne fonctionne pas, en pas à pas, ça bloque où ?

à +

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

Voir excel joint.

Dans la première colonne, l'ensemble des cellules sont remplacées par 33 ( ht des lignes).
Pour les cellules avec texte long, pas d'évolution des largeurs des lignes.

Julian

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

Désolé, oublié le fichier excel

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

dsl, j'ai été trop vite sans tester

remplace:

        M.Rows = IIf(M.RowHeight < 33, 33, M.RowHeight)

par

        M.RowHeight = IIf(M.RowHeight < 33, 33, M.RowHeight)

chez moi, ça roule (excel2010...)

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

merci


ça roule aussi sur 2002


bonne après midi

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

Bonjour à tous
Bonjour FranceDemo


Sumon fichier excel avec x macro cela ne fontionne pas. Pour les cellules fusionnées, je me retrouve avec des hauteurs de lignes correspondant à un ajustement sur base d'une cellule unique.

Je souhaite rentrer le code pour la solution suivante :

Pour les lignes de 15 à 500 ( cellule non vide)
Si la cellule A comprend + de 35 caractères et/ou B comprend + de 45 carcatères => ht de ligne =66
Si la cellule A comprend + de 70 caractères et/ou B comprend + de 90 carcatères => ht de ligne =99

Pour les lignes avec < 35 caractères => ht ligne = 33

Sheets("Feuil1").Select



J'ai commencé avec le code suivant, cela plante ( pb / double if et ajout si c <> """
Avec un If cela fonctionne.

***************
For i = 15 To 100
If Len(Range("A" & i)) > 35 Or Len(Range("B" & i)) > 45 Then Rows(i).RowHeight = 66

If Len(Range("A" & i)) > 70 Or Len(Range("B" & i)) > 90 Then Rows(i).RowHeight = 99


Next

End Sub
***********************


Merci

Julian

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

re,
tu peux essayer :

Dim CelA As Range
Dim CelB As Range

For Each CelA In Range("A15:A500")
    For Each CelB In Range("B15:B500")
        If Len(CelA) < 35 And CelB < 35 Then
            CelA.RowHeight = 33
        ElseIf Len(CelA) > 35 Or CelB > 45 Then
            CelA.RowHeight = 66
        ElseIf Len(CelA) > 70 Or CelB > 90 Then C
            elA.RowHeight = 99
        End If
    Next CelB
Next CelA

(pas testé)
à+

 

[JULIANSAT]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

FranceDemo
J'ai testé le code.
Cela "mouline" durant un certain tps.

J'ai réalisé un autre test en créant des sous macro ( bon terme ???, je suis néophyte).
Décomposition des mes If


exemple :
***********************************************************************
Sub Macro()
Macro1
Macro2
End Sub
Sub Macro1()
Sheets("Feuil1").Select

For i = 15 To 1000
If Len(Range("A" & i)) > 35 Or Len(Range("B" & i)) > 35 Then Rows(i).RowHeight = 66
Next

End Sub
Sub Macro2()
Sheets("Feuil1").Select
For i = 15 To 1000
If Len(Range("A" & i)) > 70 Or Len(Range("B" & i)) > 70 Then Rows(i).RowHeight = 99
Next

End Sub
*************************************
Le résultat est presque immédiat.
La technique est sans doute pas très "propre"


Amicalement

Julian

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

détrompe toi, ta technique est bonne, c'est normal que ma macro mouline :
je prend la première cellule de la colonne A et je passe toutes les cellule de la colonne B en revue, puis je recommence avec la deuxième cellule de la colonne A
(en fait, ma macro "fonctionne" mais elle est plutôt nulle au niveau de sa structure !!!)
par contre, pour un truc comme ça, je pense qu'il faudrait faire un essai avec un tableau, et là ce serait instantané (ou presque)
à+

 

[francedemo]

Re : Macro ajustement ht cellules fusionnées et hauteur minimale

ou alors, une autre idée:

Dim CelA As Range
Application.ScreenUpdating = False
For Each CelA In Range("A15:A500")
    If Len(CelA) < 35 And Len(CelA.Offset(0, 1)) < 35 Then
        CelA.RowHeight = 33
    ElseIf Len(CelA) > 35 Or Len(CelA.Offset(0, 1)) > 45 Then
        CelA.RowHeight = 66
    ElseIf Len(CelA) > 70 Or Len(CelA.Offset(0, 1)) > 90 Then
        CelA.RowHeight = 99
    End If
Next CelA
Application.ScreenUpdating = True

déjà, là, ça devrait aller beaucoup plus vite
à tester