XL 2021 Doublon à fusionner

Sub Fusionner()
Dim a As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Defusionner 'lance la macro
Columns(1).Insert 'insère une colonne auxiliaire
With [A1].CurrentRegion.Columns(1)
    .FormulaR1C1 = "=1/(RC[1]=OFFSET(RC[1],-1,))"
    .Value = .Value 'supprime les formules
    For Each a In .SpecialCells(xlCellTypeConstants, 1).Areas
        Union(a(0, 2), a.Columns(2)).Merge 'fusionne les noms
        Union(a(0, 3), a.Columns(3)).Merge 'fusionne les villes
    Next a
End With
Columns(1).Delete
End Sub

Sub Defusionner()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.ShowAllData 'si la feuille est filtrée
With Range("A1:B" & Cells(Rows.Count, 3).End(xlUp).Row)
    For Each c In .Cells
        If IsEmpty(c.MergeArea(1)) Then c = "µ" 'repère les cellules vides fusionnées ou non
    Next c
    .UnMerge 'défusionne
    .SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
    .Value = .Value 'supprime les formules
    .Replace "µ", "" 'efface le repérage
    .Resize(, 4).Borders.Weight = xlThin 'bordures fines
End With
End Sub

Sub Fusionner()
Dim a As Range, col%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Defusionner 'lance la macro
With Rows("1:" & Cells(Rows.Count, 3).End(xlUp).Row) 'lignes entières
    .Sort .Columns(1), xlAscending, .Columns(2), , xlAscending, Header:=xlYes 'tri sur les villes puis sur les noms
    For col = 1 To 2
        Columns(col).Insert 'insère une colonne auxiliaire entière
        With .Columns(col)
            .FormulaR1C1 = "=1/(RC[1]=OFFSET(RC[1],-1,))"
            .Value = .Value 'supprime les formules
            For Each a In .SpecialCells(xlCellTypeConstants, 1).Areas
                Union(a(0, 2), a.Columns(2)).Merge 'fusionne les villes puis les noms
            Next a
        End With
        Columns(col).Delete 'supprime la colonne auxiliaire
    Next col
End With
End Sub

Sub Defusionner()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.ShowAllData 'si la feuille est filtrée
With Range("A1:B" & Cells(Rows.Count, 3).End(xlUp).Row)
    For Each c In .Cells
        If IsEmpty(c.MergeArea(1)) Then c.MergeArea(1) = Chr(2) 'repère les cellules vides, fusionnées ou non
    Next c
    .UnMerge 'défusionne
    .SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
    .Value = .Value 'supprime les formules
    .Replace Chr(2), "" 'efface le repérage
    .Resize(, 4).Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les noms
    .Resize(, 4).Borders.Weight = xlThin 'bordures fines
End With
End Sub