Fusion automatique des cellules

**tahak** · 25/05/2016, 12h13

Bonjour,
Il m'arrive plusieurs fois de faire un travail fastidieux de fusion de cellules d'une feuille de calcul excel avec un nombre de lignes et de colonnes quelconques. Le travail consiste à :
1- fusionner les cellules identiques (rangée l'une après l'autre) sur une même colonne
2- fusionner les cellules identiques de la colonne suivante en tenant compte des fusions de la colonne d'avant
3- et ainsi de suite ...
le fichier joint illustre le cas sur 2 colonnes.
Je sollicite votre aide pour avoir une macro excel qui résout le problème.

**Kiouane** · 25/05/2016, 14h12

Je vais essayer de te guider avant de te donner une solution qui pourrait te correspondre. Penses à utiliser For each cell in Taplage avec une condition if et reviens avec une idée.

Tahak j'ai vu que ta requête doit prendre en compte les données de la colonne A quand tu fusionnes la colonne B, c'est bien çà?

**tahak** · 25/05/2016, 16h10

Merci pour ta réponse. Je ne suis pas expérimenté en macro excel mais j'ai trouvé cette macro qui doit être bricolé afin qu'elle puisse répondre à mon problème:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub FusionCellules()
Dim i As Long, j As Long, h As Long, k As Long
Application.DisplayAlerts = False
For i = 1 To Range("A65536").End(xlUp).Row 'étude colonne A
  j = 1
  While Cells(i + j, 1) = Cells(i, 1)
    Range(Cells(i, 1), Cells(i + j, 1)).MergeCells = True
    j = j + 1
  Wend
  For h = i To i + j - 1 'étude colonne B
    k = 1
    While Cells(h + k, 2) = Cells(h, 2)
      Range(Cells(h, 2), Cells(h + k, 2)).MergeCells = True
      k = k + 1
    Wend
    h = h + k - 1
  Next h
  i = i + j - 1
Next i
Application.DisplayAlerts = True
End Sub

1er défaut: pas de boucle sur les colonnes
2ème défaut: la macro ne tient pas compte de la fusion de la colonne précédente

J'espère que tu m'as bien compris

**Kiouane** · 25/05/2016, 16h16

Je ne te cache pas, j'ai bossé une bonne trentaine de minute sur ta requête et voici le résultat. Il y aura sûrement mieux. Mais dis moi si c'est ce qu'il te faut.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Sub x()
Application.ScreenUpdating = False 'Evite la mise à jour de l'écran
Application.DisplayAlerts = False 'Evite les message pour valider la fusion.
 
 
 
n = Range("B" & Rows.Count).End(xlUp).Row 'On compte le nombre de ligne de notre plage
 
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2)) 'Je pense qu'il y a mieux, mais à cause d'une erreur que j'ai remarquée, j'ai du rajouter cette ligne
cell.Value = "X"
Next
 
'Première étape on commence par ta colonne B puisque tu ne veux pas tout à fait fusionner les cellules identiques successives mais aussi prendre en compte les données de la colonne A
For Each cell In Range("B1:B" & n)
 
      For i = 1 To n - cell.Row
 
         If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value Then
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
         Else: Exit For
         End If
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
' Deuxième étape on fusionne les cellules successives et identiques de la colonne A
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2))
cell.Value = "X"
Next
For Each cell In Range("A1:A" & n)
 
      For i = 1 To n - cell.Row
 
         If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value Then
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
         Else: Exit For
         End If
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

**tahak** · 25/05/2016, 16h26

dans l'exemple que j'ai transmis, dans la colonne 2, les lignes 14 à 10 ne doivent pas fusionnées ensemble, mais on doit avoir la fusion suivante:
ligne 10, pas de fusion
fusion des lignes 11 et 12
fusion des lignes 13 et 14

l'execution de la macro me renvoie une erreur sur la ligne:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value Then

**Kiouane** · 25/05/2016, 16h30

Essai comme ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Sub x()
Application.ScreenUpdating = False 'Evite la mise à jour de l'écran
Application.DisplayAlerts = False 'Evite les message pour valider la fusion.
 
 
 
n = Range("B" & Rows.Count).End(xlUp).Row 'On compte le nombre de ligne de notre plage
 
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2)) 'Je pense qu'il y a mieux, mais à cause d'une erreur que j'ai remarquée, j'ai du rajouter cette ligne
cell.Value = "X"
Next
 
'Première étape on commence par ta colonne B puisque tu ne veux pas tout à fait fusionner les cellules identiques successives mais aussi prendre en compte les données de la colonne A
For Each cell In Range("B1:B" & n)
 
      For i = 1 To n - cell.Row
 
         If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value Then
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
         Else: Exit For
         End If
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
' Deuxième étape on fusionne les cellules successives et identiques de la colonne A
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2))
cell.Value = "X"
Next
For Each cell In Range("A1:A" & n)
 
      For i = 1 To n - cell.Row
 
 
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
 
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

**tahak** · 25/05/2016, 16h51

la première étape du programme consiste à fusionner les cellules identiques de la première colonne
sur la deuxième colonne, pour chaque plage fusionnée de la ligne1, (exemple ligne 13 à 17) on fait la même chose que l'étape1
et ainsi de suite

Ci-joint un fichier avec des données de départ et les résultats escomptés

Merci d'avance pour ton aide

**Kiouane** · 25/05/2016, 16h53

Est ce que tu as au moins tester le dernier code que je t'ai envoyé? Il fait exactement ce que tu veux pour les colonnes A et B. Fais moi un retour.

PS : Si une réponse t'as aidé, n'hésite pas à cliquer sur le pouce vert en bas à droite.

Merci :p !

**tahak** · 25/05/2016, 17h03

Merci beaucoup pour ton aide precieuse
ça marche bien sur la 1ere et la 2ème colonne
il me reste de boucler sur un nombre indéterminé de colonne...

**Kiouane** · 25/05/2016, 17h03

J'ai vu que t'as rajouté une troisième colonne, est ce que tu t'en sors pour la condition à rajouter?

**tahak** · 25/05/2016, 17h08

non pas encore

**Kiouane** · 25/05/2016, 17h10

Test ça et dis moi!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Sub x()
Application.ScreenUpdating = False 'Evite la mise à jour de l'écran
Application.DisplayAlerts = False 'Evite les message pour valider la fusion.
 
 
 
n = Range("B" & Rows.Count).End(xlUp).Row 'On compte le nombre de ligne de notre plage
 
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2)) 'Je pense qu'il y a mieux, mais à cause d'une erreur que j'ai remarquée, j'ai du rajouter cette ligne
cell.Value = "X"
Next
 
 'Première étape, on fusionne la colonne C en prenant en compte la colonne A et B
 For Each cell In Range("C3:C" & n)
 
      For i = 1 To n - cell.Row
 
         If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value And cell.Offset(0, -2).Value = cell.Offset(1, -2).Value Then
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
         Else: Exit For
         End If
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
'Deuxième étape on commence par ta colonne B puisque tu ne veux pas tout à fait fusionner les cellules identiques successives mais aussi prendre en compte les données de la colonne A
For Each cell In Range("B3:B" & n)
 
      For i = 1 To n - cell.Row
 
         If cell.Offset(0, -1).Value = cell.Offset(1, -1).Value Then
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
         Else: Exit For
         End If
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
' Troisième étape on fusionne les cellules successives et identiques de la colonne A
For Each cell In Range(Cells(n + 1, 1), Cells(n + 1, 2))
cell.Value = "X"
Next
For Each cell In Range("A3:A" & n)
 
      For i = 1 To n - cell.Row
 
 
         If cell.Value = cell.Offset(1, 0).Value Then
         With Range(cell, cell.Offset(1, 0))
         .Merge
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         End With
         Else: Exit For
         End If
 
 
 
      Next
 
 
Next
Cells(n + 1, 1).EntireRow.Delete
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

**tahak** · 25/05/2016, 17h21

encore une fois merci
juste que la ligne n'a pas été touché par la macro !

**Kiouane** · 25/05/2016, 17h22

c'est à dire? Quelle ligne?

**tahak** · 25/05/2016, 17h27

je remarque que la ligne 2 de mon fichier excel n'a pas été touché alors qu'elle devrait l’être

**Kiouane** · 25/05/2016, 17h28

C'est normal car si tu vois bien le code il commence à la ligne 3 d'où le C3 B3 A3 il suffit de changer le 3 en 2. Essai de te documenter un peu en VBA pour pouvoir comprendre les codes et les adapter à ta situation.

**tahak** · 25/05/2016, 17h32

c'est génial
encore une fois merci pour ton aide

Fusion automatique des cellules [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager