XL 2019 Ajustement automatique Hauteur de ligne en fonction du texte variable

[thespeedy20]

Bonjour le Forum,

J'ai consulter de long en large le forum mais je n'ai rien vu qui pourrait solutionner mon problème. Sur ma feuille j'ai tableau comme celui :

Les cellules sont fusionnées(Je sais c'est pas l'idéale...) Le texte que je peux y insérer peut-être de longueur variable en commençant bien sur par le n°1...
Donc ici, j'aimerais l'ajustement de la hauteur des lignes en fonction du texte... mais réduire le tableau et re numéroté et ce de façon automatique car si non à l'impression, je dépasse une page...

Je vous demande votre aide... Je vous remercie par avance ...

OLi

 

[job75]

Bonjour thespeedy20, le forum,

Voyez le fichier joint et cette macro :

Sub AjusterHauteurLignes()
Dim o As OLEObject, oo As Object, P As Range, ncol%, i&, hmax#, j%, c As Range, a, h#
Set P = Feuil1.UsedRange 'CodeName de la feuill
ncol = P.Columns.Count
Application.ScreenUpdating = False
For i = 1 To P.Rows.Count
    hmax = 0
    For j = 1 To ncol
        Set c = P(i, j)
        If c.MergeCells Then
            a = c.HorizontalAlignment 'mémorise
            With c.MergeArea
                .UnMerge 'défusionne
                .Rows(1).HorizontalAlignment = xlCenterAcrossSelection 'centre sur plusieurs colonnes
                .Rows(1).AutoFit
                h = .Rows(1).RowHeight
                If h > hmax Then hmax = h
                .Merge 'refusionne
                j = j + .Columns.Count - 1
            End With
            c.HorizontalAlignment = a 'restitution
        End If
    Next j
    If hmax Then P.Rows(i).RowHeight = hmax
Next i
End Sub

A+

 

[thespeedy20]

Bonjour Job75,

Merci pour ta proposition, j'ai du changé et mettre

Set P = Feuil1.Range("D68:AH77")

car toutes les lignes de la feuille changeaient de hauteur...

Maintenant du fait que nous avons agrandi la hauteur, je suis à l'impression sur 2 pages... Peut-on retirer la hauteur ajoutée ou supprimer une ligne ou plusieurs et renuméroter le tableau comme l'exemple du post1 ?

Merci beaucoup

OLi

 

[job75]

Pourquoi ne pas mettre 1 page en largeur et 1 page en hauteur dans le menu Mise en page ?

 

[thespeedy20]

re,
Le document ne dois faire qu'une page d'impression, uniquement en recto... voilà pourquoi...Je désirais que cela soit automatique car on se sait jamais à l'avance combien de ligne on va avoir... Parfois c 'est une, d'autres 2 ou 3...

 

[job75]

Quand on met 1 page en hauteur l'impression se fait sur 1 page quel que soit le nombre de lignes...

 

[thespeedy20]

Re,
Oups, je ne savais pas...j ai encore des choses à apprendre...cela ne change pas le format, réduire colonnes et autres....

 

[thespeedy20]

Bonjour Job75

Je tenais à te remercier pour ton aide , ton code fonctionne à la perfection...

Je me suis un peu creusé les méninges pour la suppression des lignes (enfin cacher) afin de ne garder qu'une 1 feuille... et j'a trouvé

Sub RowHeight()

Dim c As Range
Dim NbL As Double
Dim TotalRowHeight As Double
Dim HautDep As Double
Dim Diff As Double
Dim x As Integer
Dim y As Integer

' Hauteur de départ du tableau
HautDep = 130

'Calcul de la hauteur du tableau après introduction du texte
For Each c In Range("D68:D77")
TotalRowHeight = TotalRowHeight + c.Height
Next c

'Différence de hauteur constatée
Diff = TotalRowHeight - HautDep


'Nombre de ligne(s) à enlever
NbL = Diff / 12
If Int(NbL) < NbL Then NbL = Int(NbL) + 1 Else: NbL = Int(NbL)


'Calcul de la ligne de départ
y = (77 - NbL) + 1

'Cacher les ligne(s) correspondante(s)
Range("A" & y & ":A77").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True

End Sub

Sub TabOrig()

'Remttre le tableau d'origine
Range("A68:A77").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False
Feuil1.Rows("68:77").RowHeight = 12
End Sub

Je ne suis pas expert en vba, si il y a des corrections ou optimisation à faire, je suis preneur...Merci

OLi