Fusionner des cellules dans des lignes

[fireball]

Bonjour,

j'ai un tableau dans lequel se trouvent des données parfois identiques sur plusieurs lignes superposées.
exemple :
c3; c4; c5; c6 chacune valeur "voile"
B10; b11;b12;b13;b14 chacune valeur "VTT"

Mon tableau correspond à A2; m120

J'aimerai que dans ces cas là, les cellules identiques soient fusionnées afin d'avoir une meilleur lisibilité et moins de surcharge à l'écran. Je suis preneur aussi de la macro qui me permettrait éventuellement d'écrire en vertical dans ces cellules!!

Merci par avance du coup de main!
Sportivement

 

[phlaurent55]

Re : Fusionner des cellules dans des lignes

Bonjour fireball

le fait de fusionner des cellules est très souvent source de problèmes par la suite
après , si tu veux changer la valeur des cellules tu sera obligé de les "défusionner"

concernant l'écriture à la verticale, sélectionne les cellules concernées ensuite clic-droit, "format de cellules" et onglet "alignement"

à+
Philippe

 

[Hippolite]

Re : Fusionner des cellules dans des lignes

Bonjour fireball, bonjour Philippe,
Philippe t'a mis en garde avec les cellules fusionnées.
Les cellules ne doivent pas être fusionnées au préalable, sinon une cellule située sous une fusion ne fusionnera pas avec.

Public Sub Traitement()
'zône couverte A2:M120
    Application.ScreenUpdating = False
    For j = 1 To 13
        For i = 2 To 119
            If Cells(i, j).Value <> "" Then
                For k = 1 To 120 - i
                    If Cells(i + k, j).Value <> Cells(i, j).Value Then Exit For
                Next k
                Regroupe Range("A1").Offset(i - 1, j - 1).Resize(k + 1, 1)
                i = i + k - 1
            End If
        Next i
    Next j
    Application.ScreenUpdating = True
End Sub

Sub Regroupe(Target As Range)
    Application.DisplayAlerts = False
    With Target
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 90
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Application.DisplayAlerts = True
End Sub

S'il y a au préalable des cellules fusionnées, il faudra écrire une macro de défusionnage qui remplisse toutes les cellues défusionnées avec la valeur de la première cellule.
A+

 

[JNP]

Re : Fusionner des cellules dans des lignes

Bonjour le fil ,
Une proposition assez proche de celle d'Hippolite

Sub Test()
Dim Plage As Range, I As Integer, J As Integer
Application.DisplayAlerts = False
For J = 1 To 13
    For I = 2 To 120
        If Cells(I, J) = Cells(I + 1, J) And Cells(I, J) <> "" Then
            If Plage Is Nothing Then
                Set Plage = Union(Cells(I, J), Cells(I + 1, J))
            Else
                Set Plage = Union(Plage, Cells(I + 1, J))
            End If
        Else
            If Not Plage Is Nothing Then
                If Plage.Count > 1 Then
                    Plage.Merge
                    Plage.Orientation = xlVertical
                    Set Plage = Nothing
                End If
            End If
        End If
    Next I
Next J
Application.DisplayAlerts = True
End Sub

Bonne fin de jouréne

 

[fireball]

Re : Fusionner des cellules dans des lignes

et bien merci beaucoup! Ca fonctionne parfaitement!