Microsoft 365 Fusionner automatiquement des cellule identique

Sub Fusion()
     Const Plage_Fusion = "P16:P381"
     Const NomSh = "Feuil1"
     Const Texte = "ARRET USINE"
  
     Dim Wsh As Worksheet, Rg As Range, sRg As Range, Continuer as Boolean
  
     Set Rg = Range(Plage_Fusion)
     i = 1
     While i < Rg.Rows.Count
          If Rg.Cells(i, 1).Value = Texte Then
               Continuer = True
               j = 1
               While Continuer
                    If Rg.Cells(i + j, 1) = Texte Then
                         j = j + 1
                    Else
                         Continuer = False
                    End If
               Wend
               If j > 1 Then
                    Application.DisplayAlerts = False
                    Rg.Cells(i, 1).Resize(j).Merge
                    Application.DisplayAlerts = True
               End If
               i = i + j
          End If
          i = i + 1
     Wend
End Sub

Sub Fusionner()
'se lance par Ctrl+F
Dim c As Range, deb As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each c In Range("P16:P" & Range("P" & Rows.Count).End(xlUp).Row + 1) 'une cellule (vide) en bas
    If c = "ARRET USINE" And deb Is Nothing Then Set deb = c
    If c = "" And Not deb Is Nothing Then Range(deb, c(0)).Merge: Set deb = Nothing
Next
End Sub

Sub Defusionner()
'se lance par Ctrl+D
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("P16:P" & Range("P" & Rows.Count).End(xlUp).Row)
    If c.MergeCells Then
        With c.MergeArea
            c.UnMerge
            c.AutoFill .Cells
        End With
    End If
Next
End Sub