Macro fusion cellules colonne A selon valeurs colonne B

Sub fusion()
Dim Cel As Range
Dim Fus As Object
Dim It
Dim Nbr As Long, Lig As Long
Application.ScreenUpdating = False
Set Fus = CreateObject("Scripting.Dictionary")
Columns(1).Cells.UnMerge
For Each Cel In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    Fus(Cel.Value) = Cel.Value
Next Cel
For Each It In Fus.Items
    Nbr = Application.CountIf(Columns(2), It)
    Lig = Application.Match(It, Columns(2), 0)
    Cells(Lig, 1).Resize(Nbr).Merge
Next It
End Sub

Sub test()
Dim i&
With Application: .ScreenUpdating = False: DisplayAlerts = False: End With
With Sheets("Feuil1")
    .Columns(1).UnMerge
    For i = 7 To .Cells(Rows.Count, 2).End(xlUp).Row
        If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then .Range(.Cells(i, 1), .Cells(i - 1, 1)).Merge
    Next i
End With
With Application: .ScreenUpdating = True: DisplayAlerts = True: End With
End Sub

Sub fusion()
Dim Cel As Range
Dim Fus As Object
Dim It
Dim Nbr As Long, Lig As Long
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Set Fus = CreateObject("Scripting.Dictionary")
Columns(1).Cells.UnMerge
For Each Cel In Range("B7:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    Fus(Cel.Value) = Cel.Value
Next Cel
For Each It In Fus.Items
    Nbr = Application.CountIf(Columns(2), It)
    Lig = Application.Match(It, Columns(2), 0)
    Cells(Lig, 1).Resize(Nbr).Merge
Next It
End Sub