Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t As Range, r1 As Range, r2 As Range, h As Double
Set t = Intersect(Target, [B14:Q40,AE14:AM40]) 'à adapter
If t Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each t In t ' si plusieurs cellules sont modifiées
  Set r1 = Intersect(t.EntireRow, [B:Q])
  Set r2 = Intersect(t.EntireRow, [AE:AM])
  Union(r1, r2).UnMerge 'défusionne
  r1.HorizontalAlignment = xlCenterAcrossSelection
  r2.HorizontalAlignment = xlCenterAcrossSelection
  r1.Rows.AutoFit 'ajustement automatiquement
  h = r1.Rows.Height 'mémorise la hauteur
  r1.Merge: r2.Merge 'refusionne
  Union(r1, r2).HorizontalAlignment = xlGeneral
  If h < 409 Then r1.RowHeight = h 'hauteur de ligne
Next
End Sub

Sub TEST()
  Hauteur Sheets("chalet").Range("b14:ae40")
End Sub

Sub Hauteur(MaSelection As Range)
Dim i As Long, j As Long, xcell As Range, xAux As Range
Dim LigDeb As Long, LigFin As Long, ColDeb As Long, ColFin As Long
Dim HauteurDef As Single, Largeur As Single

Application.ScreenUpdating = False
LigDeb = MaSelection.Row
LigFin = MaSelection.Row + MaSelection.Rows.Count - 1
ColDeb = MaSelection.Column
ColFin = MaSelection.Column + MaSelection.Columns.Count - 1

With Sheets(MaSelection.Parent.Name)
Set xAux = .Cells(.Rows.Count, .Columns.Count)
For i = LigDeb To LigFin
  .Cells(i, 1).EntireRow.RowHeight = 3
  For j = ColDeb To ColFin
    If .Cells(i, j).MergeCells Then
      If .Cells(i, j).Address = .Cells(i, j).MergeArea(1, 1).Address Then
        xAux.EntireRow.Clear
        xAux.Value = .Cells(i, j).Text
        .Cells(i, j).Copy
        xAux.PasteSpecial Paste:=xlPasteFormats
        Largeur = 0
        For Each xcell In .Cells(i, j).MergeArea.Columns
          Largeur = Largeur + xcell.ColumnWidth
        Next xcell
        xAux.ColumnWidth = Largeur
        xAux.WrapText = True
        If .Cells(i, j).RowHeight < xAux.RowHeight Then .Cells(i, j).RowHeight = xAux.RowHeight
      End If
    End If
  Next j
Next i
xAux.Clear
End With
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t As Range
Set t = Intersect(Target, [F5:S5,AA5:AM5])
If Not t Is Nothing Then Ajustement t, [F:S], [AA:AM], xlCenter
Set t = Intersect(Target, [E9:AM9])
If Not t Is Nothing Then Ajustement t, [E:AM], [E:AM], xlCenter
Set t = Intersect(Target, [B14:Q40,AE14:AM40])
If Not t Is Nothing Then Ajustement t, [B:Q], [AE:AM], xlGeneral
End Sub

Sub Ajustement(t As Range, plage1 As Range, plage2 As Range, align)
Dim r1 As Range, r2 As Range, h As Double
Application.ScreenUpdating = False
For Each t In t ' si plusieurs cellules sont modifiées
  Set r1 = Intersect(t.EntireRow, plage1)
  Set r2 = Intersect(t.EntireRow, plage2)
  Union(r1, r2).UnMerge 'défusionne
  r1.HorizontalAlignment = xlCenterAcrossSelection
  r2.HorizontalAlignment = xlCenterAcrossSelection
  r1.WrapText = True: r2.WrapText = True 'renvoi à la ligne
  r1.Rows.AutoFit 'ajustement automatiquement
  h = r1.Rows.Height 'mémorise la hauteur
  r1.Merge: r2.Merge 'refusionne
  Union(r1, r2).HorizontalAlignment = align
  If h < 409 Then r1.RowHeight = h 'hauteur de ligne
Next
End Sub