XL 2013 code qui de-fusionne des cellules dans un tableau

[vinciHorus]

Bonjour

J'aimerais avoir un code qui de-fusionne des cellules dans un tableau comme indiqué dans ce fichier joint

merci

 

[patricktoulon]

bonjour
d’après ton exemple non seulement tu veux de fusionner mais replacer la 2d donnée
parce que juste de fusionné ca donnerait
[D8]="t"
[D14]="v"
ce qui ne donne pas tout a fait le résultat que tu présente a droite

 

[patricktoulon]

EN l'état si je me cantonne a ta demo
pour la reproduire je fait ceci

Sub test()
    Dim D As Object, C As Range
    Set D = CreateObject("scripting.dictionary")
    For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp)).Cells
        If C.MergeCells = True And Not D.exists(C.MergeArea.Address) Then
            D(C.MergeArea.Address) = C.Value
        End If
    Next
    [G8].Resize(D.Count, 1) = Application.Transpose(D.Items)
End Sub

mais je suis quasiment certain que c'a n'est pas tout a fait ça ,mais comme a ton habitude tu va nous donner les éléments 1 par 1 😉

 

[patricktoulon]

re bon ben pour une fois ce fut bref à la bonne heure 😉

 

[vinciHorus]

EN l'état si je me cantonne a ta demo
pour la reproduire je fait ceci

Sub test()
    Dim D As Object, C As Range
    Set D = CreateObject("scripting.dictionary")
    For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp)).Cells
        If C.MergeCells = True And Not D.exists(C.MergeArea.Address) Then
            D(C.MergeArea.Address) = C.Value
        End If
    Next
    [G8].Resize(D.Count, 1) = Application.Transpose(D.Items)
End Sub

mais je suis quasiment certain que c'a n'est pas tout a fait ça ,mais comme a ton habitude tu va nous donner les éléments 1 par 1 😉

c'est un élément qui entrera dans ma macro principale !!!

c'est possible de le faire sur le même tableau? (les modifications s'appliquent sur le même tableau)

 

[patricktoulon]

a ben voila je savais bien que tu allais nous sortir de ton chapeau une modif importante
c’était trop beau pour un jeudi matin

 

[patricktoulon]

re

Sub test()
    Dim D As Object, C As Range,firstrow&
    Set D = CreateObject("scripting.dictionary")
    For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp)).Cells
        If C.MergeCells = True And Not D.exists(C.MergeArea.Address) Then
            If firstrow = 0 Then firstrow = C.Row
            D(C.MergeArea.Address) = C.Value: C.MergeCells = False: C = ""
       
End If
    Next
    Cells(firstrow, "D").Resize(D.Count, 1) = Application.Transpose(D.Items)
End Sub

 

[job75]

Bonjour vinciHorus, patricktoulon, le forum,

Rien compris mais puisqu'on demande de défusionner :

Sub Sup()
With Range("D8:D" & Rows.Count)
    .UnMerge
    On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).Delete xlUp
    .CurrentRegion.Borders.Weight = xlThin 'facultatif
End With
End Sub

A+

 

[patricktoulon]

bonjour @job75
je m'incline 😉

 

[vinciHorus]

re

Sub test()
    Dim D As Object, C As Range,firstrow&
    Set D = CreateObject("scripting.dictionary")
    For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp)).Cells
        If C.MergeCells = True And Not D.exists(C.MergeArea.Address) Then
            If firstrow = 0 Then firstrow = C.Row
            D(C.MergeArea.Address) = C.Value: C.MergeCells = False: C = ""
      
End If
    Next
    Cells(firstrow, "D").Resize(D.Count, 1) = Application.Transpose(D.Items)
End Sub

cela fonctionne mais ça ne tient pas compte des bordures

 

[patricktoulon]

re
prends celui de job75

 

[patricktoulon]

re
et quoi que!!!!
si d'autre données sur la feuille vérifier si ça les fait pas remonter injustement

 

[vinciHorus]

re
et quoi que!!!!
si d'autre données sur la feuille vérifier si ça les fait pas remonter injustement

J'essaye de modifier son code pour éviter cela depuis mais pour l'instant sans succès

 

[vinciHorus]

Bonjour vinciHorus, patricktoulon, le forum,

Rien compris mais puisqu'on demande de défusionner :

Sub Sup()
With Range("D8:D" & Rows.Count)
    .UnMerge
    On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).Delete xlUp
    .CurrentRegion.Borders.Weight = xlThin 'facultatif
End With
End Sub

A+

problème de remonter d'autres valeurs

 

[patricktoulon]

re
ben tu peux pas justement donc c'est l'option dico pour toi