Microsoft 365 Défusionner et recopier texte dans les 2 cases

[Moreno076]

Bonjour à tous.

Je voudrais savoir si il est possible de défusionner une cellule et de recopier automatiquement dans les 2 cellules la même chose.

Dans le fichier ci-joint J ai besoin de défusionner B7 et aussi C7.

Merci pour votre aide

 

[job75]

Bonsoir Moreno076,

S'il n'y a que 2 cellules à défusionner ça ne vaut pas le coup d'utiliser le VBA, s'il y en a beaucoup par contre :

Sub Defusionne()
Dim i&
Application.ScreenUpdating = False
With Feuil1 'CodeName
    With .Range("A1", .UsedRange)
        For i = 7 To .Rows.Count
            With .Cells(i, 2).MergeArea
                If .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
            With .Cells(i, 3).MergeArea
                If .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
        Next
    End With
End With
End Sub

Pas difficile de compléter les bordures à la fin si nécessaire.

A+

 

[Modeste geedee]

Bonsou®

Je voudrais savoir si il est possible de défusionner une cellule et de recopier automatiquement dans les 2 cellules la même chose

selectionner la cellule
puis séquence de touches
Alt L U U L
puis
ctrl-B

en pourra avantageusement utiliser l'enrgistreur de macro :
Sub Macro1()
' Macro1 Macro
Selection.UnMerge
Selection.FillDown
End Sub

 

[Moreno076]

Bonsoir Moreno076,

S'il n'y a que 2 cellules à défusionner ça ne vaut pas le coup d'utiliser le VBA, s'il y en a beaucoup par contre :

Sub Defusionne()
Dim i&
Application.ScreenUpdating = False
With Feuil1 'CodeName
    With .Range("A1", .UsedRange)
        For i = 7 To .Rows.Count
            With .Cells(i, 2).MergeArea
                If .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
            With .Cells(i, 3).MergeArea
                If .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
        Next
    End With
End With
End Sub

Pas difficile de compléter les bordures à la fin si nécessaire.

A+

Salut JOB75.

C'est exactement ce que je veux sauf que ca recopie des valeurs que je ne veux pas mais avec les filtres j'arrive à mes fins. Merci beaucoup

 

[Moreno076]

Bonsou®

selectionner la cellule
puis séquence de touches
Alt L U U L
puis
ctrl-B

en pourra avantageusement utiliser l'enrgistreur de macro :
Sub Macro1()
' Macro1 Macro
Selection.UnMerge
Selection.FillDown
End Sub

Merci mais c'est bon j'ai opté pour la solution de Job75

 

[Moreno076]

Job75 je viens de m'apercevoir d'une coquille

Voir fichier ci joint cela ne fonctionne pas lorsque j'ai beaucoup de lignes.

Merci

 

[job75]

Cela fonctionne trop bien au contraire puisque les lignes de titres sont aussi défusionnées !

Pour l'éviter remplacez dans la macro .Count > 1 par .Count = 2

Qui fonctionne bien quand les cellules fusionnées ne contiennent que 2 cellules.

Sinon il faut repérer les lignes de titres, par leurs couleurs par exemple.

 

[job75]

On peut aussi utiliser sur votre fichier la propriété Bold (gras) :

Sub Defusionne()
Dim i&
Application.ScreenUpdating = False
With Feuil1 'CodeName
    With .Range("A1", .UsedRange)
        For i = 7 To .Rows.Count
            With .Cells(i, 2).MergeArea
                If Not .Font.Bold And .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
            With .Cells(i, 3).MergeArea
                If Not .Font.Bold And .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
        Next
    End With
End With
End Sub

 

[Moreno076]

On peut aussi utiliser sur votre fichier la propriété Bold (gras) :

Sub Defusionne()
Dim i&
Application.ScreenUpdating = False
With Feuil1 'CodeName
    With .Range("A1", .UsedRange)
        For i = 7 To .Rows.Count
            With .Cells(i, 2).MergeArea
                If Not .Font.Bold And .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
            With .Cells(i, 3).MergeArea
                If Not .Font.Bold And .Count > 1 Then .UnMerge: .Value = .Cells(1)
            End With
        Next
    End With
End With
End Sub

Merci JOB75 c'est celle là qui me convient !!! Merci beaucoup et bonnes fêtes.