XL 2013 Ajustement automatique hauteur de ligne

M

Moussetictac

XLDnaute Nouveau
Bonjour,

J'aimerais savoir si c'est possible d'ajuster automatiquement la hauteur d'une cellule fusionnée dans un document Excel, avec une macro dont je n'ai malheureusement pas la maîtrise ?

En exemple, je téléverse un fichier.

Je remercie déjà très sincèrement la personne qui pourra me donner une réponse … clé en mains.

Avec mes salutations les meilleures et à tout bientôt, j'espère :)

Moussetictac
 

Pièces jointes

  • Ajustement automatique.xlsx
    10.4 KB · Affichages: 34
Trier par date Trier par votes
Cousinhub

Cousinhub

XLDnaute Barbatruc
Bonjour,
Bonjour @job75 😉
Une variante à l'excellent code fourni dans ce fil.
J'utilise l'évènement "Change", qui ne se déroulera qu'en cas de cellule fusionnée.
L'idée :
- Si la cellule est vide, on met la hauteur à la hauteur "consigne", soit 30
- Si la cellule comporte un ou plusieurs "Alt + Entrée", on défusionne, on centre sur plusieurs colonnes, on ajuste la hauteur en automatique (dont on note la valeur), on refusionne, et on remet à la valeur enregistrée (sinon, la hauteur double...)
A mettre dans le code de la feuille :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim Plg As Range
If Target.MergeCells Then
    If Target(1).Value = "" Then
        Target.RowHeight = 30
    ElseIf InStr(1, Target, Chr(10)) > 0 Then
        Set Plg = Target.MergeArea
        With Plg
            .UnMerge
            .HorizontalAlignment = xlCenterAcrossSelection
            .EntireRow.AutoFit
            Haut_Lig = .RowHeight
            .Merge
            .RowHeight = Haut_Lig
        End With
    End If
End If
End Sub
Bonne journée
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Avec l'évènement Workbook_SheetSelectionChange dans le ThisWorkbook du fichier joint :
VB: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim RH, c As Range, L, CW, i&, h
RH = 25 'hauteur à adapter
Application.ScreenUpdating = False
Sh.Unprotect "" 'déprotection sans mot de passe
For Each c In Sh.UsedRange
    If Not c.Locked Then If c.RowHeight <> RH Then c.RowHeight = RH 'RAZ
Next c
If Not Target(1).Locked Then
    L = Target.Width: CW = Target(1).ColumnWidth
    Target.UnMerge 'défusionne
    For i = 1 To 510 'largeur maximum d'une colonne 255
        Target(1).ColumnWidth = i / 2
        If Target(1).Width > L Then Target(1).ColumnWidth = (i - 1) / 2: Exit For
    Next i
    Target(1).WrapText = True 'renvoi à la ligne
    Target(1).Rows.AutoFit 'ajustement hauteur
    Target(1).ColumnWidth = CW
    h = Target.RowHeight
    Target.Merge 'refusionne
    Target.RowHeight = h
    If Target.RowHeight < RH Then Target.RowHeight = RH
End If
Sh.Protect "" 'protection sans mot de passe
End Sub

Bonjour bhbh.

C'est mon 37000 ième post !
 

Pièces jointes

  • Copie de brouillon -V00000003(1).xlsm
    195.7 KB · Affichages: 3
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Je confirme...
Bravo
1666186320599.png


Flashé!!!
Fais bien attention à toi :)
 
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
bhbh à dit:
Bonjour,
Bonjour @job75 😉
Une variante à l'excellent code fourni dans ce fil.
J'utilise l'évènement "Change", qui ne se déroulera qu'en cas de cellule fusionnée.
L'idée :
- Si la cellule est vide, on met la hauteur à la hauteur "consigne", soit 30
- Si la cellule comporte un ou plusieurs "Alt + Entrée", on défusionne, on centre sur plusieurs colonnes, on ajuste la hauteur en automatique (dont on note la valeur), on refusionne, et on remet à la valeur enregistrée (sinon, la hauteur double...)
A mettre dans le code de la feuille :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim Plg As Range
If Target.MergeCells Then
    If Target(1).Value = "" Then
        Target.RowHeight = 30
    ElseIf InStr(1, Target, Chr(10)) > 0 Then
        Set Plg = Target.MergeArea
        With Plg
            .UnMerge
            .HorizontalAlignment = xlCenterAcrossSelection
            .EntireRow.AutoFit
            Haut_Lig = .RowHeight
            .Merge
            .RowHeight = Haut_Lig
        End With
    End If
End If
End Sub
Bonne journée
Cliquez pour agrandir...
Bonjour,

Super! c'est exactement ce que je voulais. Pouvons nous éalement rajouter le code pour justifier à gauche?
 
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
job75 à dit:
Avec l'évènement Workbook_SheetSelectionChange dans le ThisWorkbook du fichier joint :
VB: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim RH, c As Range, L, CW, i&, h
RH = 25 'hauteur à adapter
Application.ScreenUpdating = False
Sh.Unprotect "" 'déprotection sans mot de passe
For Each c In Sh.UsedRange
    If Not c.Locked Then If c.RowHeight <> RH Then c.RowHeight = RH 'RAZ
Next c
If Not Target(1).Locked Then
    L = Target.Width: CW = Target(1).ColumnWidth
    Target.UnMerge 'défusionne
    For i = 1 To 510 'largeur maximum d'une colonne 255
        Target(1).ColumnWidth = i / 2
        If Target(1).Width > L Then Target(1).ColumnWidth = (i - 1) / 2: Exit For
    Next i
    Target(1).WrapText = True 'renvoi à la ligne
    Target(1).Rows.AutoFit 'ajustement hauteur
    Target(1).ColumnWidth = CW
    h = Target.RowHeight
    Target.Merge 'refusionne
    Target.RowHeight = h
    If Target.RowHeight < RH Then Target.RowHeight = RH
End If
Sh.Protect "" 'protection sans mot de passe
End Sub

Bonjour bhbh.

C'est mon 37000 ième post !
Cliquez pour agrandir...
Merci beaucoup! Bravo pour le 370000 ième post ;-)
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re-,
Pour justifier, rajoute 2 lignes :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim Plg As Range
If Target.MergeCells Then
    If Target(1).Value = "" Then
        Target.RowHeight = 30
    ElseIf InStr(1, Target, Chr(10)) > 0 Then
        Set Plg = Target.MergeArea
        With Plg
            .UnMerge
            .HorizontalAlignment = xlCenterAcrossSelection
            .EntireRow.AutoFit
            Haut_Lig = .RowHeight
            .Merge
            .RowHeight = Haut_Lig
            .HorizontalAlignment = xlJustify
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
    End If
End If
End Sub
Bon courage
 
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
Merci à tous les deux. J'en profite pour vous demander un autre chose.

Je sohaiterais ajouter une image a laquelle je veux affecter une macro pour que le formulaire revienne à zero

Pour cela, j'ai trouver un code VBA qui me permettre de coher et décocher tous les style de controle
J'ai enregistrer une macro pour effacer toute les sasies faite et une autre pour remettre les mentions qu'il y avait la saisie.

Le hic, (en plus du fait que mes codes sont compliqués, et je suis certaine qu'il y a plus simple) je ne sais pas les combinée en une seul macro, pour que la manip s'exécute en une fois

Ci-dessous les codes :
Décoche des controles :
VB: 
Sub test_I()
'coche tous les types de CheckBox
Application.ScreenUpdating = False
Cochez True
End Sub
Sub test_II()
'décoche tous les types de CheckBox
Application.ScreenUpdating = False
Cochez False
End Sub

Private Sub Cochez(statut As Boolean)
Dim c As Object
With ActiveSheet
    .CheckBoxes.Value = statut
    For Each c In .OLEObjects
    If TypeName(c.Object) = "CheckBox" Then c.Object.Value = statut
    Next c
End With
End Sub

Effacement des données :
Code: 
Sub Efaccement()
'
' Efaccement Macro
'

'
    Range("B6:H6").Select
    Selection.ClearContents
    Range("N6:T6").Select
    Selection.ClearContents
    Range("F8:J8").Select
    Selection.ClearContents
    Range("F9:J9").Select
    Selection.ClearContents
    Range("F10:J10").Select
    Selection.ClearContents
    Range("P8:T8").Select
    Selection.ClearContents
    Range("P9:T9").Select
    Selection.ClearContents
    Range("P10:T10").Select
    Selection.ClearContents
    Range("F12:T12").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("B27:T27").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("G37:J49").Select
    Selection.ClearContents
    Range("N37:Q49").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("F56:T56").Select
    Selection.ClearContents
    Range("Q58:T58").Select
    Selection.ClearContents
    Range("C61:S61").Select
    Selection.ClearContents
    Range("C64:S64").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("C69:S69").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=4
    Range("C75:S75").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("H81:K95").Select
    Selection.ClearContents
    Range("M81:P95").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("C98:S98").Select
    Selection.ClearContents
    Range("D101:K101").Select
    Selection.ClearContents
    Range("K103:R104").Select
    Selection.ClearContents
    Range("M107:S107").Select
    Selection.ClearContents
    Range("M108:S108").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("K112:S112").Select
    Selection.ClearContents
    Range("K113:S113").Select
    Selection.ClearContents
    Range("E114:I114").Select
    ActiveWindow.SmallScroll Down:=4
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("C122:S122").Select
    Selection.ClearContents
    Range("C124:S124").Select
    Selection.ClearContents
    Range("C126:S126").Select
    Selection.ClearContents
    Range("C130:O130").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("D137:N137").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("C145:S145").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=4
    Range("M151:S151").Select
    Selection.ClearContents
    Range("M152:S152").Select
    Selection.ClearContents
    Range("G155:K155").Select
    Selection.ClearContents
    Range("G156:K156").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("M157:S157").Select
    Selection.ClearContents
    Range("N162:S162").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("J165:S165").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("I171:R171").Select
    Selection.ClearContents
    Range("G173:I173").Select
    Selection.ClearContents
    Range("K174:S174").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("G178:J185").Select
    Selection.ClearContents
    Range("P178:S184").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("H188:K188").Select
    Selection.ClearContents
    Range("F195:S195").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("C199:S199").Select
    Selection.ClearContents
    Range("C201:S201").Select
    Selection.ClearContents
    Range("F205:S205").Select
    Selection.ClearContents
    Range("F207:I207").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("F209:S209").Select
    Selection.ClearContents
    Range("F212:R212").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("F207:I207").Select
    Selection.ClearContents
    Range("I226:P226").Select
    ActiveWindow.SmallScroll Down:=12
    Selection.ClearContents
    Range("G234:S234").Select
    Selection.ClearContents
    Range("G235:S235").Select
    Selection.ClearContents
    Range("G236:S236").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("P240:R240").Select
    Selection.ClearContents
    Range("P243:R243").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("I251:S251").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("C254:S254").Select
    Selection.ClearContents
    Range("C259:S260").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=20
    Range("C280:S280").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("C292:S292").Select
    ActiveSheet.Unprotect
    Selection.ClearContents
    Range("C295:S295").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("L299:S299").Select
    Selection.ClearContents
    Range("L300:S300").Select
    Selection.ClearContents
    Range("L301:S301").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=8
    Range("C305:S305").Select
    Selection.ClearContents
    Range("C307:S307").Select
    Selection.ClearContents
    Range("C309:S309").Select
    Selection.ClearContents
      Range("K312:N312").Select
    Range("K312:N312").Select
    Selection.ClearContents
    Range("K314:N314").Select
    Selection.ClearContents
    Range("K316:N316").Select
    Selection.ClearContents
    Range("K318:N318").Select
    Selection.ClearContents
    Range("K320:N320").Select
    Selection.ClearContents
    Range("K322:N323").Select
    Selection.ClearContents
    Range("K325:N326").Select
    Selection.ClearContents
    Range("K328:N328").Select
    Selection.ClearContents
    Range("K330:N330").Select
    Selection.ClearContents
    Range("C332:S332").Select
    Selection.ClearContents


VB: 
ub Remplissage()
'
' Remplissage Macro

    Range("B6:H6").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour entrer une date"
    Range("N6:T6").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    Range("F9:J9").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("F10:J10").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("P8:T8").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("P9:T9").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("P10:T10").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("F12:T12").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("B27:T27").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("F56:T56").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("C61:S61").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("C64:S64").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("C69:S69").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C75:S75").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C98:S98").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("D101:K101").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    Range("M107:S107").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour entrer une date"
    Range("M108:S108").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour entrer une date"
    Range("K112:S112").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("K113:S113").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("E114:I114").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("C122:S122").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C124:S124").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C126:S126").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C130:O130").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    Range("D137:N137").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("C145:S145").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    
    Range("M151:S151").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    
    Range("M152:S152").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("G155:K155").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("G156:K156").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("M157:S157").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("N162:S162").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("J165:S165").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("I171:R171").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("G173:I173").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    
    Range("K174:S174").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("H188:K188").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("F195:S195").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("C199:S199").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C201:S201").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("F205:S205").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("F207:I207").Select
    ActiveCell.FormulaR1C1 = "Choisissez un élément"
    
    Range("F209:S209").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("F212:R212").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("I226:P226").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    
    Range("G234:S234").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("G235:S235").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("G236:S236").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("P240:R240").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("P243:R243").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("I251:S251").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie"
    Range("C254:S254").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("C259:S260").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
    Range("K267:L267").Select
    ActiveCell.FormulaR1C1 = "% à préciser"
  
    Range("K268:L268").Select
    ActiveCell.FormulaR1C1 = "% à préciser"
    Range("K269:L269").Select
    ActiveCell.FormulaR1C1 = "% à préciser"
    Range("C280:S280").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
 
    Range("C292:S292").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("C295:S295").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("L299:S299").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("L300:S300").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("L301:S301").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("C305:S305").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"
  
    Range("C307:S307").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"

    Range("C309:S309").Select
    ActiveCell.FormulaR1C1 = "Cliquez ici pour la saisie - Attention : pour aller à la ligne ALT+Entrée"


Merci d'avance.
Linda
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Linda42 à dit:
Encore moi,

J'ai un beug quand je veux protéger ma feuille. Ça ne fonctionne plus. Pour rapple, j'ai bien dévérouillé les cellule qui sont à saisir.
Cliquez pour agrandir...
Re-,
Dans le code, suffit de déprotéger en tout début, et de reprotéger à la fin du code
Avec l'enregistreur de macro :
Démarrer l'enregistrement
Protéger la feuille avec les options voulues
Stopper l'enregistrement
Le code est généré, reste à l'insérer dans le code de mise à hauteur
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
La macro Workbook_SheetSelectionChange du post #18 agrandit les cellules déverrouillées uniquement quand elles sont sélectionnées.

Maintenant si l'on veut que leurs hauteurs soient toujours ajustées à leurs contenus on utilisera cette macro Workbook_SheetChange, fichier (2) :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim RH, L, CW, HA, i&, h
RH = 25 'hauteur à adapter
If Target.Locked Then Exit Sub 'sécurité
Application.ScreenUpdating = False
Sh.Unprotect "" 'déprotection sans mot de passe
Set Target = Target.MergeArea
L = Target.Width: CW = Target(1).ColumnWidth: HA = Target.HorizontalAlignment
Target.UnMerge 'défusionne
For i = 1 To 510 'largeur maximum d'une colonne 255
    Target(1).ColumnWidth = i / 2
    If Target(1).Width > L Then Target(1).ColumnWidth = (i - 1) / 2: Exit For
Next i
Target(1).WrapText = True 'renvoi à la ligne
Target(1).Rows.AutoFit 'ajustement hauteur
h = Target.RowHeight
Target(1).ColumnWidth = CW
Target.Merge 'refusionne
Target.RowHeight = h
Target.HorizontalAlignment = HA
If Target.RowHeight < RH Then Target.RowHeight = RH
Sh.Protect "" 'protection sans mot de passe
End Sub
 

Pièces jointes

  • Copie de brouillon -V00000003(2).xlsm
    196.4 KB · Affichages: 1
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
job75 à dit:
La macro Workbook_SheetSelectionChange du post #18 agrandit les cellules déverrouillées uniquement quand elles sont sélectionnées.

Maintenant si l'on veut que leurs hauteurs soient toujours ajustées à leurs contenus on utilisera cette macro Workbook_SheetChange, fichier (2) :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim RH, L, CW, HA, i&, h
RH = 25 'hauteur à adapter
If Target.Locked Then Exit Sub 'sécurité
Application.ScreenUpdating = False
Sh.Unprotect "" 'déprotection sans mot de passe
Set Target = Target.MergeArea
L = Target.Width: CW = Target(1).ColumnWidth: HA = Target.HorizontalAlignment
Target.UnMerge 'défusionne
For i = 1 To 510 'largeur maximum d'une colonne 255
    Target(1).ColumnWidth = i / 2
    If Target(1).Width > L Then Target(1).ColumnWidth = (i - 1) / 2: Exit For
Next i
Target(1).WrapText = True 'renvoi à la ligne
Target(1).Rows.AutoFit 'ajustement hauteur
h = Target.RowHeight
Target(1).ColumnWidth = CW
Target.Merge 'refusionne
Target.RowHeight = h
Target.HorizontalAlignment = HA
If Target.RowHeight < RH Then Target.RowHeight = RH
Sh.Protect "" 'protection sans mot de passe
End Sub
Cliquez pour agrandir...
Bonjour,

J'ai finalement opter pour ton code, mais j'ai un bug qui vient d'apparaître et je n'arrive pas à trouver le problème.
Ci-jiont le fichier. Le bug concerne la feuille formulaire de saisie et la marco associer au dessin de la gomme.
Lorsque je clique dessus toutes les cellule s'efface bien sauf la dernière qui engendre une erreur. Je comprends pas.
Je n'ai pas pu envoyer le fichier entier car il fait 1.4MO, le fichier final à d'autre feuille.
Peux-tu m'aider.
 

Pièces jointes

  • Brouillon_V2.xlsm
    323.6 KB · Affichages: 4
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
Microsoft 365 Gestion numéros de pages du classeur dans une cellule
2
Réponses
16
Affichages
760
sousou
sousou
T
  • Question
XL 2019 Ajustement automatique Hauteur de ligne en fonction du texte variable
Réponses
7
Affichages
2 K
thespeedy20
T
A
  • Résolu(e)
Microsoft 365 Remplissage automatique de 2 champs selon ce qui est selectionné dans la 1ère colonne (menu déroulant)
Réponses
6
Affichages
940
AnSo!
A
A
  • Question
XL pour MAC outils tableau, création automatique de ligne à partir d'un autre tableau
Réponses
5
Affichages
811
axel211
A
J
  • Question
XL 2016 Création de macros diverses
Réponses
0
Affichages
1 K
Jérôme57
J
T
  • Question
XL 2016 Problème de conditions
Réponses
1
Affichages
876
nat54
nat54
D
  • Question
XL 2019 VBA interface préparation de commandes
Réponses
1
Affichages
926
decolit
D
M
  • Question
XL 2019 Onglet de synthèse
Réponses
2
Affichages
788
_Thierry
_Thierry
S
  • Question
XL 2010 Saisie automatique de données Planning Formation
Réponses
0
Affichages
1 K
Serious E
S
G
  • Question
Microsoft 365 Tableau de présence à l'entraînement
Réponses
0
Affichages
2 K
georlo
G

Membres actuellement en ligne

2 membres et 53 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 963
Messages
2 093 996
Membres
105 906
dernier inscrit
aifa