Ajustement hauteur de ligne au contenu
m
Bonjour,
j'ai un code pour la gestion de l'ajustement de la hauteur de ligne par rapport au retour à la ligne via le bouton entrée (donc en forçant le retour à la ligne)
j'aimerai un code permettant de gérer et le retour à la ligne simple tout en gardant le retour à la ligne de manière forcer
voici le code que j'utilise :
Sub AR_hauteur_ligne()
Dim tbl As Variant
Dim lastRow As Long, lastCol As Long
Dim A As Integer
Dim I As Long, J As Long
Dim dblCounter As Double
Application.ScreenUpdating = False
With Sheets("AR")
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(26, Columns.Count).End(xlToLeft).Column
For I = 26 To lastRow
dblCounter = 0
For J = 2 To lastCol
If Not IsEmpty(Cells(I, J)) Then
tbl = Split(Cells(I, J).Value, Chr(10))
dblCounter = UBound(tbl) + 1
If (20 * dblCounter) > .Rows(I).RowHeight Then
.Rows(I).RowHeight = 20 * dblCounter
c = dblCounter - 1
For z = 1 To c
If .Rows(I).RowHeight <> 20 Then
supp = lastRow + 1
If .Rows(supp).RowHeight = 45 Then
Set CEL = .Range("A" & supp - 15 & ":L" & supp).Find("*Titre*", LookIn:=xlValues, lookat:=xlWhole)
If .Range("B" & CEL.Row + 3) Like "*Périmètre*" Then
Sheets("ModAR").Rows("1:24").Copy
.Rows(supp + 1).Insert Shift:=xlDown
.Rows(supp - 1).Copy .Rows(supp + 5)
.Rows(supp - 1).Delete
Else
Sheets("ModAR").Rows("25:48").Copy
.Rows(supp + 1).Insert Shift:=xlDown
.Rows(supp - 1).Copy .Rows(supp + 5)
.Rows(supp - 1).Delete
If .Rows(supp + 4).RowHeight <> 20 Then
x = .Rows(supp + 4).RowHeight / 20
For y = 1 To x
.Rows(supp + 6).Delete
Next y
.Rows(supp).PageBreak = xlPageBreakManual
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(25, Columns.Count).End(xlToLeft).Column
I = I + 5
End If
End If
Else
.Rows(supp).Delete
End If
End If
Next z
End If
End If
Next J
Next I
End With
End Sub
Merci de votre aide
Mika