Fusion de cellule Excel

Sub FusionCellule()
Dim DerLigne As Integer, i As Integer, RD As Range
Dim e As Integer
'------- Pas nécessaire si un seul classeur
    Workbooks("Classeur1").Activate
'------------------------------------------
    Application.DisplayAlerts = False 
'------------------------------------------
    Sheets("feuil1").Select
    DerLigne = Range("A65536").End(xlUp).Row
    For i = 1 To DerLigne
        If Range("A" & i).Value <> vbNullString Then
            Set RD = Range("A" & i)
            For e = i + 1 To DerLigne
                If RD.Value <> Cells(e, 1).Value Then Exit For
            Next e
            If e - 1 > i Then  'Si une seule fois la valeur
                Range("A" & i & ":A" & e - 1).Select
                With Selection
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                i = e - 1
            End If
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

Sub aligner_criteres()
Dim ligact As Long, fin As Long, nbre As Integer, ref As String
Application.ScreenUpdating = False
fin = Range("A65536").End(xlUp).Row + 1
ligact = 2
While ligact < fin
    ref = Cells(ligact, 1)
    nbre = Application.CountIf(Range("A:A"), ref)
    If nbre > 1 Then
        For cptr = ligact + 1 To ligact + nbre - 1
            colcrit = Cells(cptr, 13).End(xlToLeft).Column '13 correspond à la colonne M
            Cells(ligact, colcrit) = Cells(cptr, colcrit)
        Next
        Rows(ligact + 1 & ":" & ligact + nbre - 1).Delete
    End If
ligact = ligact + 1
fin = Range("A65536").End(xlUp).Row + 1
Wend

End Sub