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

vinciHorus

XLDnaute Junior
Bonjour

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

merci
 

Pièces jointes

  • Classeur1te.xlsm
    143.3 KB · Affichages: 11
Solution
Bonjour vinciHorus, patricktoulon, le forum,

Rien compris mais puisqu'on demande de défusionner :
VB:
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

XLDnaute Barbatruc
EN l'état si je me cantonne a ta demo
pour la reproduire je fait ceci
VB:
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 ;)
 

vinciHorus

XLDnaute Junior
EN l'état si je me cantonne a ta demo
pour la reproduire je fait ceci
VB:
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

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

vinciHorus

XLDnaute Junior
re
VB:
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
 

Discussions similaires

Réponses
4
Affichages
246
Réponses
8
Affichages
270
Réponses
4
Affichages
327

Statistiques des forums

Discussions
311 709
Messages
2 081 754
Membres
101 812
dernier inscrit
trufu