Sub FusionCellules()
Dim RangeRestant As Range
Dim Réponse As Variant
Dim Nb As Integer
Dim FusionLignes As Boolean
Dim ErrNumber As Long
If Not TypeOf Selection Is Range Then Exit Sub
If Selection.Areas.Count > 1 Then Exit Sub
If Selection.Cells.Count = 1 Then Exit Sub
Set RangeRestant = Selection
Do While 1
Réponse = Application.InputBox("Fusionner des cellules en lignes (L) ou en colonnes (C) ?", "Fusion", "C", Type:=2)
If VarType(Réponse) = vbBoolean Then Exit Sub
Select Case UCase(Réponse)
Case "C"
FusionLignes = False
Exit Do
Case "L"
FusionLignes = True
Exit Do
Case Else
MsgBox "Répondre 'L' pour fusion de lignes ou 'C' pour fusion de colonnes."
End Select
Loop
Do While Not RangeRestant Is Nothing
'Fusion de lignes
If FusionLignes Then
Réponse = Application.InputBox("Combien de lignes sont à fusionner ?", "Fusion", RangeRestant.Rows.Count, Type:=1)
If VarType(Réponse) = vbBoolean Then Exit Sub
Nb = CInt(Réponse)
If Nb = 0 Or Nb > RangeRestant.Rows.Count Then
MsgBox "Le nombre de lignes à fusionner dépasse les limites du range restant"
Else
If RangeRestant.Cells(1, 1).Resize(Nb, RangeRestant.Columns.Count).Cells.Count = 1 Then
MsgBox "Il faut au moins 2 cellules pour une fusion"
Else
On Error Resume Next
RangeRestant.Cells(1, 1).Resize(Nb, RangeRestant.Columns.Count).MergeCells = True
ErrNumber = Err.Number
On Error GoTo 0
If ErrNumber = 0 Then
If RangeRestant.Rows.Count = Nb Then
Set RangeRestant = Nothing
Else
Set RangeRestant = RangeRestant.Cells(Nb + 1, 1).Resize(RangeRestant.Rows.Count - Nb, RangeRestant.Columns.Count)
If RangeRestant.Cells.Count = 1 Then
Set RangeRestant = Nothing
Else
MsgBox "Encore " & RangeRestant.Rows.Count & " lignes à fusionner"
End If
End If
End If
End If
End If
'Fusion de colonnes
Else
Réponse = Application.InputBox("Combien de colonnes sont à fusionner ?", "Fusion", RangeRestant.Columns.Count, Type:=1)
If VarType(Réponse) = vbBoolean Then Exit Sub
Nb = CInt(Réponse)
If Nb = 0 Or Nb > RangeRestant.Columns.Count Then
MsgBox "Le nombre de colonnes à fusionner dépasse les limites du range restant"
Else
If RangeRestant.Cells(1, 1).Resize(RangeRestant.Rows.Count, Nb).Cells.Count = 1 Then
MsgBox "Il faut au moins 2 cellules pour une fusion"
Else
On Error Resume Next
RangeRestant.Cells(1, 1).Resize(RangeRestant.Rows.Count, Nb).MergeCells = True
ErrNumber = Err.Number
On Error GoTo 0
If ErrNumber = 0 Then
If RangeRestant.Columns.Count = Nb Then
Set RangeRestant = Nothing
Else
Set RangeRestant = RangeRestant.Cells(1, Nb + 1).Resize(RangeRestant.Rows.Count, RangeRestant.Columns.Count - Nb)
If RangeRestant.Cells.Count = 1 Then
Set RangeRestant = Nothing
Else
MsgBox "Encore " & RangeRestant.Columns.Count & " colonnes à fusionner"
End If
End If
End If
End If
End If
End If
Loop
MsgBox "Fusion terminée."
End Sub