Fusionnée cellule identique - VBA

Version imprimable

09/07/2015, 23h05
sawsliders

Fusionnée cellule identique - VBA

Bonjour,(rebonjour pour ceux qui m'ont déjà beaucoup aidé en ce jours.

Alors j'aurais encore une question

J'ai dans une feuille avec X ligne (nombre variable)

dans cette feuille j'ai des valeur dans la colonne B qui ce répété.

Je voudrais crée une fusion si dans Cellule B4 et B5 sont identique alors les fusionnée

Parfois il peux i avoir plusieurs répétition de valeur (s'il y en a 10 il faux fusionné les 10, si 100 fusionnée les 100 ...) dans tout les cas elle sont adjacente entre-elles

Auriez-vous un bout de script pour du VBA qui pourrait m'aider à trouvé une solution.

Par la suite j'aurais une autre question avec ce bout de scripte :p mais déjà cette partie la sera débloquant pour moi.

Par avance merci beaucoup pour votre travaille parfait surtout bénévole.

Filipe D

Bonsoir Felipe, bonsoir le forum,

Attention ! Les cellules fusionnées sont ennemies jurées de VBA. Si tu dois coder par la suite avec des cellules fusionnées c'est bien plus galère qu'avec des cellules qui se répètent. Je ne te le conseille pas..

Le code pour le faire :

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
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim SD As Variant 'déclare la variable SD (Sans Doublon)
Dim NO As Variant 'déclare la variable NO (Nombre d'Occurrences)
 
Set O = Sheets("Feuil1") 'définit l'onglet O (à adapter)
DL = O.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet O
Set PL = O.Range("B1:B" & DL) 'définit la plage PL
TC = PL 'définit le tableau de cellules TC
Set D = CreateObject("SCripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellues TC
    D(TC(I, 1)) = D(TC(I, 1)) + 1 'alimente le dictionnaire D
Next I 'prochaine ligne de la boucle
SD = D.keys 'récupère la liste sans doublon dans le tableau SD
NO = D.items 'récupère le nombre d'occurence de chaque élément de SD dans le tableau NO
Application.DisplayAlerts = False 'empêche les messages d'Excel (la fusion de plusieurs cellues éditées déclenche un message)
For I = 0 To UBound(NO, 1) 'boucle sur tous les éléments du tableau NO
    If NO(I) > 1 Then 'condition : si le nombre d'occurrences de l'élément de la boucle est supérieur à 1
        Set R = O.Columns(2).Find(SD(I), O.Cells(DL, 2), xlValues, xlWhole) 'recherche l'élément entier dans la colonne 2 (=B) de l'onglet O
        R.Resize(NO(I), 1).Merge 'redimensionne l'élément trouvé et le fusionne
    End If 'fin de la condition
Next I 'prochain élément du tableau NO
Application.DisplayAlerts = True 'affiche les messages d'Excel
End Sub

Citation:

Envoyé par Thautheme

Attention ! Les cellules fusionnées sont ennemies jurées de VBA. Si tu dois coder par la suite avec des cellules fusionnées c'est bien plus galère qu'avec des cellules qui se répètent. Je ne te le conseille pas..

Tout d'abord grand merci encore une fois je vois qu'en plus d’être hyper actif sur le forum tu as une tres grand largeur de connaissance.

Alors j'ai du modifié un peux le code :

Changé la variable I en A puisque je dispose déjà dans mon code sources (les autre bout avant celui la) une variable I.

Es-que j'ai fait une erreur ?

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
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim A As Integer 'déclare la variable I (Incrément)
Dim SD As Variant 'déclare la variable SD (Sans Doublon)
Dim NO As Variant 'déclare la variable NO (Nombre d'Occurrences)
 
Set O = Sheets("Feuil1") 'définit l'onglet O (à adapter)
DL = O.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet O
Set PL = O.Range("B1:B" & DL) 'définit la plage PL
TC = PL 'définit le tableau de cellules TC
Set D = CreateObject("SCripting.Dictionary") 'définit le dictionnaire D
For A = 1 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellues TC
    D(TC(A, 1)) = D(TC(A, 1)) + 1 'alimente le dictionnaire D
Next A 'prochaine ligne de la boucle
SD = D.keys 'récupère la liste sans doublon dans le tableau SD
NO = D.items 'récupère le nombre d'occurence de chaque élément de SD dans le tableau NO
Application.DisplayAlerts = False 'empêche les messages d'Excel (la fusion de plusieurs cellues éditées déclenche un message)
For A = 0 To UBound(NO, 1) 'boucle sur tous les éléments du tableau NO
    If NO(A) > 1 Then 'condition : si le nombre d'occurrences de l'élément de la boucle est supérieur à 1
        Set R = O.Columns(2).Find(SD(I), O.Cells(DL, 2), xlValues, xlWhole) 'recherche l'élément entier dans la colonne 2 (=B) de l'onglet O
        R.Resize(NO(A), 1).Merge 'redimensionne l'élément trouvé et le fusionne
    End If 'fin de la condition
Next A 'prochain élément du tableau NO
Application.DisplayAlerts = True 'affiche les messages d'Excel
End Sub

J'ai bloque à la ligne (à la fin), es-du à mon changement de I en A ?

Code:

R.Resize(NO(A), 1).Merge 'redimensionne l'élément trouvé et le fusionne

Merci encore du coup de main :).

10/07/2015, 13h55
Thautheme

Re,

Tu as oublié de modifier dans cette ligne :

Code:

Set R = O.Columns(2).Find(SD(I), O.Cells(DL, 2), xlValues, xlWhole) 'recherche l'élément entier dans la colonne 2 (=B) de l'onglet O

qui devient :

Code:

Set R = O.Columns(2).Find(SD(A), O.Cells(DL, 2), xlValues, xlWhole) 'recherche l'élément entier dans la colonne 2 (=B) de l'onglet O
10/07/2015, 14h11
sawsliders

Bonjour,

Exacte j'ai oublié cette ligne la.

Par contre cela ne résout pas mon probleme :s. il plante toujours au même endroit
10/07/2015, 14h37
Thautheme

1 pièce(s) jointe(s)

Re,

Aucun planton chez moi ! Voir pièce jointe...
10/07/2015, 19h04
sawsliders

Bonjour,

Effectivement je n'ai pas compris pourquoi cela ne marchais pas.

J'ai copié collé le scripte et la magie sa marché :p.
07/07/2019, 18h18
lacorniste

Citation:

Envoyé par Thautheme

Re,

Aucun planton chez moi ! Voir pièce jointe...

C'est super je cherche ça depuis plusieurs jour.

J'ai une question comment faire pour que cette action se réalise de la colonne B à la colonne BH ?

Merci de votre aide
Lucie
08/07/2019, 08h50
Thautheme

Bonjour Lucie, bonjour le forum,

Fusionner les colonne B à BH ?! Quel critère ?!... On devrait pouvoir adapter le code mais il faudrait que tu sois plus explicite...