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

Moreno076

XLDnaute Impliqué
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
 

Pièces jointes

  • fusion.xlsx
    9.6 KB · Affichages: 8

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Moreno076

XLDnaute Impliqué
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 :
VB:
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
 

job75

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

XLDnaute Barbatruc
On peut aussi utiliser sur votre fichier la propriété Bold (gras) :
VB:
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

XLDnaute Impliqué
On peut aussi utiliser sur votre fichier la propriété Bold (gras) :
VB:
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.
 

Discussions similaires

Réponses
2
Affichages
312