XL 2016 Fusionner les cellules ayant la même date en colonne B

Private Sub CommandButton1_Click()
Dim datas() As Variant
Dim lg As Long
ReDim datas(0 To 1)
Dim Lig() As Range
ReDim Lig(0)
    Set datas(0) = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
        datas(1) = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1).Value
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim UnionRange As Range
'on explore la colonne B à partir de la ligne 3, vers le bas
For lg = LBound(datas(1), 1) To UBound(datas(1), 1)
        If Dico.Exists(datas(1)(lg, 1)) Then
            Set UnionRange = Dico.Item(datas(1)(lg, 1))
            Set UnionRange = Union(UnionRange, datas(0)(lg, 1))
            Dico.Remove datas(1)(lg, 1)
            Dico.Add datas(1)(lg, 1), UnionRange
        Else
            Set Lig(UBound(Lig)) = datas(0)(lg, 1)
            Dico.Add datas(1)(lg, 1), Lig(UBound(Lig))
            ReDim Preserve Lig(UBound(Lig) + 1)
        End If
Next lg
    ReDim Preserve Lig(UBound(Lig) - 1)
    Application.DisplayAlerts = False
    For Each k In Dico.keys
        Set Value = Dico.Item(k)
        Value.Merge
    Next k
    Application.DisplayAlerts = True
[C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

'solution de Laurent950 le 07082023 #4 ExcelDownloadForum
Dim datas() As Variant...

Sub fusion()
Dim der&, t, ref, n&, i&, deb As Range
   With Sheets("Feuil1")
      Application.DisplayAlerts = False: Application.ScreenUpdating = False
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "b").End(xlUp).Row + 1
      Set deb = .Range("b3"): t = Range("b3:b" & der): ref = t(1, 1)
      Range("b3:b" & der - 1).Borders.LineStyle = xlContinuous: n = 1
      For i = 1 To UBound(t)
         If t(i, 1) <> ref Then
            deb.Resize(i - n).Merge
            ref = t(i, 1): n = i: Set deb = deb.Offset(1)
         End If
      Next i
      Application.DisplayAlerts = True: Application.ScreenUpdating = True
   End With
End Sub

'la fusion des jours identiques
'Solution proposée par Mapomme le 08.08.2023 #6 ExcelDownloadForum (Fusionner les cellules ayant la même date en colonne B)

Private Sub CommandButton1_Click()
Dim dat As Date
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next 'si aucune SpecialCell
With [B2].CurrentRegion
    If .Rows.Count = 1 Then Exit Sub
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri si ce n'est pas fait
    For dat = .Cells(2, 1) To .Cells(.Rows.Count, 1)
        .Replace dat, "#N/A"
        .SpecialCells(xlCellTypeConstants, 16).Merge
        .Replace "#N/A", dat
    Next
End With
End Sub

Private Sub CommandButton1_Click()
Dim Rng, datas As Range
    Set datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim UnionRange As Range
Dim k As Variant
For Each rgn In datas
        If Dico.Exists(rgn.Value2) Then
            Set UnionRange = Union(Dico.Item(rgn.Value2), rgn)
            Dico.Remove rgn.Value2
            Dico.Add rgn.Value2, UnionRange
        Else
            Dico.Add rgn.Value2, rgn
        End If
Next rgn
    Application.DisplayAlerts = False
    For Each k In Dico.keys
        Set UnionRange = Dico.Item(k)
            UnionRange.Merge
    Next k
    Application.DisplayAlerts = True
[C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

Private Sub CommandButton1_Click()
Dim datas As Range
    Set datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim Rng As Range
Dim UnionRange As Range
Application.DisplayAlerts = False
    For Each rgn In datas
            If Dico.Exists(rgn.Value2) Then
                Set UnionRange = Union(Dico.Item(rgn.Value2), rgn)
                Dico.Remove rgn.Value2
                Dico.Add rgn.Value2, UnionRange
                UnionRange.Merge
            Else
                Dico.Add rgn.Value2, rgn
            End If
    Next rgn
    Application.DisplayAlerts = True
    [C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

'contours hauts et bas en colonne B
der = [D120].End(3).Row
With Range("B3:G" & der)
 .Borders(xlEdgeTop).LineStyle = xlContinuous
 .Borders(xlEdgeBottom).LineStyle = xlContinuous
 .Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With

Cells(lgd, 5) = (Len(PAN.Cells(lg, col)) - Len(Replace(PAN.Cells(lg, col), "ZZ", ""))) / 2

=SOMME(--(NB.SI(DECALER($G$7;{0};{6.7.8.9.10.11.12.13.14.15.16.17.18.19.20.21.22.23.24.25.26.27.28.29.30.31.32.33.34.35.36.37.38.39.40.41.42.43.44.45.46.47.48.49.50.51.52}*1;1;1);$BB$7)>0))