[VBA-E] Hauteur automatique des lignes pour cellules fusionnées

[Couettecouette]

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Trouvercellfusionnées() 
Dim cell As Range 
  With ActiveSheet.UsedRange 
    For Each cell In .Cells 
      With cell 
          If .MergeCells = True Then 
          .Activate 
          .RowHeight = 12.75 
          Call AutoFitMergedCellRowHeight 
          End If 
      End With 
    Next cell 
  End With 
End Sub

Avec cette deuxième macro :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub AutoFitMergedCellRowHeight() 
'MAcro de Jim Rech 
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single 
Dim CurrCell As Range 
Dim ActiveCellWidth As Single, PossNewRowHeight As Single 
  If ActiveCell.MergeCells Then 
    With ActiveCell.MergeArea 
      .WrapText = True 'enclenche le renvoi à la ligne automatique (modif fs) 
      If .Rows.Count = 1 Then 'And .WrapText = True Then 
        Application.ScreenUpdating = False 
        CurrentRowHeight = .RowHeight 
        ActiveCellWidth = ActiveCell.ColumnWidth 
        For Each CurrCell In Selection 
          MergedCellRgWidth = CurrCell.ColumnWidth + _ 
            MergedCellRgWidth 
        Next 
       .MergeCells = False 
       .Cells(1).ColumnWidth = MergedCellRgWidth 
       .EntireRow.AutoFit 
        PossNewRowHeight = .RowHeight 
       .Cells(1).ColumnWidth = ActiveCellWidth 
       .MergeCells = True 
       .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _ 
         CurrentRowHeight, PossNewRowHeight) 
      End If 
    End With 
  End If 
End Sub

Toujours démarrer sur la macro Trouvercellfusionnées bien sûr.
Les deux macros sont à placer dans un module.