XL 2016 Enlever Fusion

[Bibouden1]

Bonjour à tous

J'ai un petit tableau excel (pièce jointe) protégé par un mot de passe (123) où pour quelques agents on peu choisir chaque jour une activité.

Si pour deux jours consécutifs on a la même activité (voir agent 1 samedi/dimanche) j'ai fait un bouton fusionner pour fusionner les deux jours consécutifs.
Vous pouvez faire l'essai de fusionner pour l'agent2 (foot deux jours consécutifs).

Mon problème c'est pour défusionner une cellule fusionner. J'ai un bouton "enlever fusionner les cellules" qui fonctionne mais je voudrais en même temps qu'il enlève la fusion de la cellule qu'il me remette la liste déroulante dans la deuxième cellule qui a perdu celle liste déroulante lorsque l'on clique sur "enlèver fusionner les cellules".

MErci de votre aide

 

[soan]

Bonjour Bibouden1,

Bienvenue sur le site XLD !

sans ouvrir, ton fichier, voici juste une piste :

pour dé-fusionner des cellules, utilise .UnMerge

par exemple : [B3].UnMerge

soan

 

[Bibouden1]

Bonjour Bibouden1,

Bienvenue sur le site XLD !

sans ouvrir, ton fichier, voici juste une piste :

pour dé-fusionner des cellules, utilise .UnMerge

par exemple : [B3].UnMerge

soan

Bonjour Soan

Oui j'ai une macro ou j'utilise unmerge mais ma macro est incomplete car je voudrais quand unmerge se fait que dans les cellules défusionnée la liste déroulante qu'il y avait auparavant réapparaisse.

Merci en tout cas

 

[job75]

Bonjour Bibouden1, soan,

Voyez le fichier joint et ces macros :

Sub Fusionner()
Dim P As Range, ncol%, i&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Protect "123", UserInterfaceOnly:=True
Set P = [A3].CurrentRegion 'à adapter
ncol = P.Columns.Count
For i = 2 To P.Rows.Count
    For j = ncol To 3 Step -1
        If P(i, j) <> "" Then If P(i, j) = P(i, j - 1) Then P(i, j - 1).Resize(, 2).Merge
Next j, i
End Sub

Sub Enlever_fusion()
Dim r As Range
Application.ScreenUpdating = False
ActiveSheet.Protect "123", UserInterfaceOnly:=True
Set r = [A3].CurrentRegion 'à adapter
For Each r In r
    With r.MergeArea
        If .Count > 1 Then
            .UnMerge
            r.AutoFill .Cells
        End If
    End With
Next
End Sub

 

[Bibouden1]

Bonjour Bibouden1, soan,

Voyez le fichier joint et ces macros :

Sub Fusionner()
Dim P As Range, ncol%, i&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Protect "123", UserInterfaceOnly:=True
Set P = [A3].CurrentRegion 'à adapter
ncol = P.Columns.Count
For i = 2 To P.Rows.Count
    For j = ncol To 3 Step -1
        If P(i, j) <> "" Then If P(i, j) = P(i, j - 1) Then P(i, j - 1).Resize(, 2).Merge
Next j, i
End Sub

Sub Enlever_fusion()
Dim r As Range
Application.ScreenUpdating = False
ActiveSheet.Protect "123", UserInterfaceOnly:=True
Set r = [A3].CurrentRegion 'à adapter
For Each r In r
    With r.MergeArea
        If .Count > 1 Then
            .UnMerge
            r.AutoFill .Cells
        End If
    End With
Next
End Sub

Bonjour Job75

Merci beaucoup c'est quasi ce qu'il me faut sauf que cela fusionne toute les cellules accollé ayant la même info et cela défusionne toutes les cellules fusionnées.
Moi je voudrais que cela fusionne que les cellules selectionnées pas les autres et qu'on enlève la fusion que sur la cellule qui est selectionée et de laisser les autres telles qu'elle.

Par contre super j'ai bien la liste déroulante qui est à nouveau présente.

Si tu peux faire quelque chose je te remercie

 

[job75]

Fichier (2) :

Sub Fusionner()
Dim P As Range
ActiveSheet.Protect "123", UserInterfaceOnly:=True
With [A3].CurrentRegion 'à adapter
    If .Rows.Count > 1 And .Columns.Count > 1 Then Set P = Intersect(Selection.Areas(1).Rows(1), .Cells(2, 2).Resize(.Rows.Count - 1, .Columns.Count - 1))
End With
If Not P Is Nothing Then Application.DisplayAlerts = False: P.Merge: P.Borders.Weight = xlThin: P.Select
End Sub

Sub Enlever_fusion()
If Not Selection(1).MergeCells Then Exit Sub
ActiveSheet.Protect "123", UserInterfaceOnly:=True
With Selection(1).MergeArea
    .UnMerge
    .Cells(1).AutoFill .Cells
    .Cells(1).Select
End With
End Sub

 

[Bibouden1]

Fichier (2) :

Sub Fusionner()
Dim P As Range
ActiveSheet.Protect "123", UserInterfaceOnly:=True
With [A3].CurrentRegion 'à adapter
    If .Rows.Count > 1 And .Columns.Count > 1 Then Set P = Intersect(Selection.Areas(1).Rows(1), .Cells(2, 2).Resize(.Rows.Count - 1, .Columns.Count - 1))
End With
If Not P Is Nothing Then Application.DisplayAlerts = False: P.Merge: P.Borders.Weight = xlThin: P.Select
End Sub

Sub Enlever_fusion()
If Not Selection(1).MergeCells Then Exit Sub
ActiveSheet.Protect "123", UserInterfaceOnly:=True
With Selection(1).MergeArea
    .UnMerge
    .Cells(1).AutoFill .Cells
    .Cells(1).Select
End With
End Sub

Super merci beaucoup Job75
C'est magique

 

[soan]

coucou Bibouden1,

c'est le post #6 de job75 (salut) que tu aurais dû cocher comme résolu, pas ton post #7 !

soan