Ajuster hauteurs de ligne automatiquement à la saisie (cells fusionnées)

Le 07/10/2020 à 22:59

Salut tout le monde,

Petit soucis frustrant...

Je n'arrive pas à trouver de codes pour faire en sorte que les hauteurs de lignes soient ajustées automatiquement à la saisie dans des cellules fusionnées.

Le code de base est simple, je l'ai trouvé et compris :

Private Sub Worksheet_Calculate()
    With Range("B40:E47")
        .EntireRow.autofit
    End With
End Sub

Mais il ne fonctionne pas et je pense que c'est à cause de mes cellules fusionnées.

Vous trouverez ci-dessous le document Excel.

On parle de l'onglet total des départements, et des lignes 40 à 47 et des lignes 51 à 53.

15prototype-audit-test.zip (384.66 Ko)

Merci d'avance pour le coup de main

Le 12/10/2020 à 17:40

Salut tout le monde,

Je refais un petit up...

Merci d'avance

Laurent

Le 12/10/2020 à 18:03

Bonjour toutes et tous

en effectuant un enregistrement de macro cela donne (qui sans doute peut être amélioré)

à placer dans la feuille total des départements

Private Sub Worksheet_Activate()
    Range("B40:D47").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Selection.Merge
    Range("b51:b53").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With

    Selection.Merge
  '  Range("B40:D47").Select
End Sub

@ tester

ou plus simple enfin je crois

Private Sub Worksheet_Activate()
    Range("B40:D47,b51:d53").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End Sub

crdlt,

André

Le 12/10/2020 à 18:46

Bonjour à tous,

S'il s'agit de saisie, j'aurais tendance à choisir l'évènement worksheet_change :

Private Sub Worksheet_Change(byval target as range)
if not intersect(target, range("B40:E47")) is nothing then
    target.rows.autofit
end if
End Sub

Je n'ai pas testé donc je ne suis pas certain que ça marche.

Cdlt,

Le 12/10/2020 à 20:23

Bonjour toutes et tous,

coucou et Merci 3GB

j'y avais pensé mais,

je n'ai pas réussi l'intégration de ton code dans Worksheet_Change

crdlt,

André

Le 13/10/2020 à 00:54
Andre13 a écrit :

Bonjour toutes et tous

en effectuant un enregistrement de macro cela donne (qui sans doute peut être amélioré)

à placer dans la feuille total des départements

Private Sub Worksheet_Activate()
    Range("B40:D47").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Selection.Merge
    Range("b51:b53").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With

    Selection.Merge
  '  Range("B40:D47").Select
End Sub

@ tester

ou plus simple enfin je crois

Private Sub Worksheet_Activate()
    Range("B40:D47,b51:d53").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End Sub

crdlt,

André

Salut,

Merci pour la proposition.

Malheureusement, le code ne fonctionne pas de façon automatique au moment de la saisie, et de plus il fusionne les cellules alors qu'il s'agit juste d'augmenter la largeur des lignes.

J'essaye de travailler dessus mais je n'arrive toujours pas à le faire fonctionner.

Le 13/10/2020 à 00:56
3GB a écrit :

Bonjour à tous,

S'il s'agit de saisie, j'aurais tendance à choisir l'évènement worksheet_change :

Private Sub Worksheet_Change(byval target as range)
if not intersect(target, range("B40:E47")) is nothing then
    target.rows.autofit
end if
End Sub

Je n'ai pas testé donc je ne suis pas certain que ça marche.

Cdlt,

Bonjour,

J'ai testé ton code mais il ne se passe rien malheureusement. Est-ce que c,est bien dans le worksheet_change que je dois le mettre?

Bonne soirée

Le 13/10/2020 à 09:11

Bonjour toutes et tous

merci du retour

@ tester, bidouillage il doit y avoir plus propre, teste sur largeur de la cellule uniquement B40 de l'onglet Total des départements du classeur

à placer dans la feuille total départements

Private Sub Worksheet_Calculate()
    With Range("B40:b40")
    Rows(Target.Row).AutoFit
        Selection.Rows.AutoFit
 .MergeCells = False
 .Rows.AutoFit

    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    With Range("B40:b40")
    Rows(Target.Row).AutoFit
        Selection.Rows.AutoFit
     .MergeCells = False
     .Rows.AutoFit

    End With
End Sub
7prototype-audit-test2-copie.zip (372.53 Ko)
je test avec des phrases et des mots   pour avoir un aperçu  si la ligne va se redimensionner  avec ce contenu ci-présent, pour l'instant c'est la cellule  B40 ,  je n'ai pas encore bu mon deuxième café, je croise les doigts, même si je ôte le texte la ligne se remet à sa bonne hauteur, je pense que nous sommes sur le bon chemin.
Le 13/10/2020 à 09:59

Salut Laurent, Salut Andre13,

J'ai moi aussi essayé de bidouiller. C'est un problème que je m'étais déjà posé et qui est assez "m*rdeux" je trouve pour un bénéfice nul.

J'ai pas du tout regardé ta solution André, j'espère qu'elle marche bien parce que la mienne est approximative .

Voici ma proposition, qu'il faudra adapter (remarques en bas) :

Private Sub Worksheet_Change(ByVal target As Range)
If Not Intersect(target, Range("B40:E47")) Is Nothing Then
    With Rows(target.Row)
        With Intersect(Range("B:E"), .Cells)
            .MergeCells = True
            .WrapText = True
            .VerticalAlignment = xlTop
            .HorizontalAlignment = xlJustify
        End With
        .RowHeight = 14 * WorksheetFunction.RoundUp(Len(target.Value) / 68, 0) '<<<<< hauteur variable
    End With
End If
End Sub

Ici, la hauteur de ligne de base est de 14 (pour moi en tout cas). Il faut arriver à trouver le nombre de caractères à partir duquel on renvoie à la ligne. Dans mon cas, c'était 68 (mais ce n'est toujours pas d'une fiabilité sans faille malheureusement car ça dépend de la police et des caractères). Donc, si la longueur du texte est supérieure à 68, roundup renvoie 2, si sup à 68 * 2, roundup renvoie 3. C'est un autofit artisanal disons...

Cdlt,

Rechercher des sujets similaires à "ajuster hauteurs ligne automatiquement saisie fusionnees"