Microsoft 365 Fusionner automatiquement des cellule identique

[sebastien176]

Bonjour à tous,

Comme écrit dans le titre, je voudrais pouvoir fusionner automatiquement des cellules identique

Dans la colonne "D" (de D16 à D381"), les cases comprises entre les dates du petit tableau (ci-dessous) se colorent et se remplissent automatiquement

Par contre chaque cellule comporte le texte "ARRET USINE" (voir ci-dessous)

J'aimerais que ces cellules soient fusionnées automatiquement par VBA ou macro

Merci par avance de votre aide

Bonne journée à tous

Seb

 

[AtTheOne]

Bonsoir @sebastien176 , bonsoir à tous

Essai ce bout de code en ajoutant un petit bouton sur ta feuille pour appeler la macro :

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

Bien sûr après l'exécution si tu veux annuler la fusion seule une cellule par plage dé-fusionnée conservera la formule.

Amicalement
Alain

 

[Gael]

Bonjour Seb,

Ci-joint une possibilité sans macros.

Sachant que tu travaille a priori à la semaine, je te propose une solution avec les modifs suivantes :
- J'ai rajouté un numéro de semaine après les dates de fermetures en AA9 et AA12
- La formule de calcul est modifiée pour calculer les cellules appartenant à l'une de ces semaines
- les zones sont fusionnées par semaine
- Police de caractère réduite pour que le texte tienne dans la zone

Dis-moi si ça peut te convenir.

Gaël

 

[job75]

Bonsoir sebastien176, At TheOne, Gael,

Voyez le fichier joint et ces 2 macros :

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

Elles se lancent par les raccourcis clavier indiqués.

A+

 

[AtTheOne]

Bonsoir @job75

Efficace !

Amicalement
Alain

 

[sebastien176]

Bonjour et merci à vous 3,

Je retiens la solution de Job75 car elle correspond exactement a ce que je veux faire de plus il y a l'option Défusionner 😉
Merci encore à vous 3 et bonne journée

Seb