Microsoft 365 Fusionner automatiquement des cellule identique

sebastien176

XLDnaute Junior
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
1643985859699.png


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

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

Merci par avance de votre aide

Bonne journée à tous

Seb
 

Pièces jointes

  • Nouveau Feuille de calcul Microsoft Excel.xlsm
    116.6 KB · Affichages: 11
  • 1643985961839.png
    1643985961839.png
    703 bytes · Affichages: 21

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir @sebastien176 , bonsoir à tous

Essai ce bout de code en ajoutant un petit bouton sur ta feuille pour appeler la macro :
VB:
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
 
Dernière édition:

Gael

XLDnaute Barbatruc
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
 

Pièces jointes

  • Calendrier_pointage.xlsm
    124.9 KB · Affichages: 5

job75

XLDnaute Barbatruc
Bonsoir sebastien176, At TheOne, Gael,

Voyez le fichier joint et ces 2 macros :
VB:
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+
 

Pièces jointes

  • Nouveau Feuille de calcul Microsoft Excel(1).xlsm
    124.2 KB · Affichages: 12

Discussions similaires

Réponses
12
Affichages
488

Statistiques des forums

Discussions
311 731
Messages
2 081 993
Membres
101 856
dernier inscrit
Marina40