Fusion de cellule sous condition

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

J'ai crée un emploi du temps qui se présente de la manière suivante

Pièce jointe 434563

j'ai le code suivant mais quelque chose ne marche pas, avez vous une idée ??
Code:

1 2 3 4 5 6 7 8 9 10 11 12 For Each c In Worksheets("Feuil1").Range("B2", Range("IV1").End(xlToLeft)) c.Activate Application.DisplayAlerts = False Départ = ActiveCell.Address Do While ActiveCell.Row < 15 If ActiveCell <> ActiveCell.Offset(1, 0) Then Range(Départ, ActiveCell.Address).Merge Départ = ActiveCell.Offset(1, 0).Address End If ActiveCell.Offset(1, 0).Activate Loop Next
Merci beaucoup

Bonjour,

Je suppose que vous voulez fusionner les cellules identiques d'une même colonne!

Pour Fusionner

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Fusionner()
    Dim DerLig As Long, DerCol As Long, L As Long, C As Long
    Dim Dep As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    DerLig = [A10000].End(xlUp).Row
    DerCol = [IV1].End(xlToLeft).Column
 
    For C = 2 To DerCol
        For L = DerLig To 2 Step -1
            If Cells(L, C) <> "" And Cells(L - 1, C) <> "" Then
                If Cells(L, C) = Cells(L - 1, C) Then Range(Cells(L, C), Cells(L - 1, C)).Merge
            End If
    Next L, C
End Sub

Pour Défusionner

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub Defusionner()
    Application.ScreenUpdating = False
    Sheets("Feuil1").Select
    DerLig = [A10000].End(xlUp).Row
    DerCol = [IV1].End(xlToLeft).Column
    Range("B2").Select
 
    Do While ActiveCell.Row <= DerLig
        Do While ActiveCell.Column <= DerCol
            ZoneSelect = Selection.Address
            NbCell = Range(ZoneSelect).Count
            If NbCell = 1 Then
                ActiveCell.Offset(0, 1).Activate
                GoTo Suite1
            Else
                Libelle = ActiveCell.Value
                Range(ZoneSelect).Select
                With Selection
                    .MergeCells = False
                    .Value = Libelle
                End With
                ActiveCell.Offset(0, NbCell).Activate
                GoTo Suite1
            End If
Suite1:
        Loop
        Cells(ActiveCell.Row + 1, 2).Activate
    Loop
    Range(Cells(2, 2), Cells(DerLig, DerCol)).Borders().Weight = xlThin
End Sub

Avec le fichier en exemple
Pièce jointe 434619

Cdlt

1 pièce(s) jointe(s)

re
bonjour comme ca vite fait pour defusionner les fusion
exemple

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub unmergecellule()
    Dim cel As Range, vv$, add$
    With ActiveSheet.Range("B2", Cells(Rows.Count, "D").End(xlUp))' ADAPTER LA PLAGE ICI!!!!!
        For Each cel In .Cells
            If cel.MergeArea.Cells.Count > 1 Then
                vv = cel.MergeArea.Cells(1).Value: add = cel.MergeArea.Address: cel.MergeArea.MergeCells = False
                cel.Parent.Range(add).Cells.Value = vv
            End If
        Next
    End With
End Sub

c'est plus simple non ?
Pièce jointe 434638
et pour simplifier la vie pour la fusion et sauter les cellule deja fusionnée se servir de ca aussi ;)

15/12/2018, 13h18
mika2626

Super, ca marche ! Merci à vous. 8-)