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
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
c'est un élément qui entrera dans ma macro principale !!!EN l'état si je me cantonne a ta demo
pour la reproduire je fait ceci
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 1VB: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
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
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
cela fonctionne mais ça ne tient pas compte des borduresre
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
J'essaye de modifier son code pour éviter cela depuis mais pour l'instant sans succèsre
et quoi que!!!!
si d'autre données sur la feuille vérifier si ça les fait pas remonter injustement
problème de remonter d'autres valeursBonjour vinciHorus, patricktoulon, le forum,
Rien compris mais puisqu'on demande de défusionner :
A+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