Fusion automatique des cellules en doublon VBA
Bonjour à tous,
Je possède un fichier Excel qui contient un tableau avec beaucoup de doublons en colonne A qui représente les "catégories".
J'aimerais pour une question de visuel (export PDF), pouvoir fusionner les cellules identiques qui se suivent comme dans l'illustration ci dessous.
Dans un monde parfait, la macro pourrait aussi faire la même chose dans les sous catégories en "colonne B" mais ne devra pas fusionner deux doublons issus de deux catégories différentes :
D'avance merci pour votre aide et belle journée,
Ci joint le fichier source.
Salutations,
Bonjour,
Essayez ceci:
Cdlt
Bonjour Maverick, bonjour Arturo,
Comme je me suis également intéressé au problème, je me permets de vous montrer ma solution.
Amicalement.
Merci à tous les deux pour vos contributions.
Je vais avancer avec ça et reviens vers vous pour vous dire qu'elle solution j'ai pu mettre en place.
Est-il possible d'ajouter des gardes fou pour éviter les erreurs en cas de case vide dans une des colonnes ?
Bonne fin de semaine à tous et à très vite
Oui, mais il faudrait savoir à quoi ressemble réellement ton fichier avec ces cellules vides.
Bonjour
Bojour à tous
Plus on est de fous, plus on rit !
Une autre variante :
Bye !
Bonsoir,
j'ai testé les différents fichiers.
Arturo83 : ça marche bien, il manque l'alignement vertical...
gmb : ça marche nickel !
Yvouille : j'ai modifier la liste des provenance afin d'avoir une banane venant de France pour vérifier la règle indiquée "pas de fusion ici" et là plantage d'Excel...
MAVERICK39 n'a que l'embarras du choix !
@ bientôt
LouReeD
Bonjour,
Merci à LouReeD pour son info. Voici une version corrigée.
Bonne soirée.
Bonsoir à tous
Avec tant de bonnes réponses, difficile d'être un peu original. Je vais essayer de l'être un tout petit peu : Une tentative sans VBA avec une MFC sans toucher aux données et sans fusionner.
1) Sélectionner la zone à traiter et appliquez-y toutes les bordures
2) Sélectionner la zone de la colonne A à partir de la deuxième ligne des données (ici la ligne 3) et appliquer la MFC :
- formule : =A3=A2
- Format de nombre personnalisé: ;;; (3 points-virgules)
- Bordure: pas de bordure supérieure
3) Sélectionner la zone de la colonne B à partir de la deuxième ligne des données (ici la ligne 3) et appliquer la MFC :
- formule : =ET(A3=A2;B3=B2)
- Format de nombre personnalisé: ;;; (3 points-virgules)
- Bordure: pas de bordure supérieure
Re,
On peut appliquer le principe de la MFC via un code VBA. Cliquer sur le bouton Hop!
Dans ce cas il n'y a pas de MFC, on formate simplement chaque cellule de la source selon les conditions de la MFC du précédent message.
Un avantage de ne pas fusionner est qu'on conserve la liberté de trier ou non alors que si on fusionne les tris ultérieures deviennent impossibles.
Le code est dans le module de la feuille :
Sub FormaterEnDur()
Dim der&, t, i&
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
der = .Cells(.Rows.Count, "a").End(xlUp).Row
.Range("a1:b" & der).Borders.LineStyle = xlContinuous
.Range("a1:b" & der).NumberFormat = "general"
t = .Range("a1:b" & der).Value
For i = 3 To UBound(t)
If t(i, 1) = t(i - 1, 1) Then
.Cells(i, 1).NumberFormat = ";;;": .Cells(i, 1).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
If t(i, 2) = t(i - 1, 2) Then
.Cells(i, 2).NumberFormat = ";;;": .Cells(i, 2).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
End If
End If
Next i
End With
End SubBonsoir,
mafraise, c'est ce que j'essayai de faire, à la manière de feu Steelson ici.
Bravo à vous !
Suite à mes difficultés je me suis résigné, surtout en lisant le début du message du demandeur :
J'aimerais pour une question de visuel (export PDF), alors un centrage suite à un merge c'est "plus joli"...
@ bientôt
LouReeD
@LouReed
Suite à ton message, je suis allé consulter le message de Steelson ici .
C'est vraiment très astucieux pour centrer (il fallait la sortir celle-la!). Mais ça ne fonctionne (me semble-t-il) que s'il n'y a qu'un seul bloc pour chaque valeur (différente) dans la colonne A. S'il y a deux blocs disjoints avec la même valeur en A, alors le NB.SI de la formule ne fonctionne plus. Néanmoins je pense que la plupart du temps c'est ce que l'utilisateur désire et cette formule de derrière les fagots fait le travail. Dans mon exemple j'ai pris le cas général où un bloc de valeurs peut apparaitre à différents endroits. Encore une fois la formule de Steelson est très "sioux" et très élégante
bonjour MAVERICK39, MaFraise, LouReeD, Yvouille,GMB,
une question amusante ! La même chose mais sans trier ou MFC(
BsAlv, manque plus que le centrage vertical !
@ bientôt
LouReeD
@LouReeD, salut,
??? ... au début de la macro
PS @Yvouille, il faut rester dans sa propre logique.
Si personne n'est autorisé à aborder les sujets qui vous sont appropriés, alors vous n'êtes pas non plus autorisé à le faire avec les autres. C'est un couteau à 2 tranchants.
J'attends toujours des excuses pour votre langage dans vos MPs.Bonjour,
et ben si vous tendez des pièges ! Le bouton n'est pas lié à la dernière proposition !
Forcément en réglant la chose c'est mieux !
@ bientôt
LouReeD
@ LouReeD, je m'excuse pour cette piège
Non ! C'est à moi d'être attentif !
@ bientôt
LouReeD
Bonsoir à tous,
Après tout le monde, mais ça le fait dans tous les cas de figure et sans trier
Option Explicit
Sub Fusion()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim derLig As Long, i As Long, debCol1_a_Fus As Long, debCol2_a_Fus As Long
debCol1_a_Fus = 2: debCol2_a_Fus = 2
With Sheets(1) '1ère feuille du classeur
derLig = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To derLig
If .Cells(i, 1) <> .Cells(i + 1, 1) Then
With .Range(.Cells(debCol1_a_Fus, 1), .Cells(i, 1))
.Merge
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlCenter
End With
With .Range(.Cells(debCol2_a_Fus, 2), .Cells(i, 2))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
debCol1_a_Fus = i + 1
debCol2_a_Fus = i + 1
ElseIf .Cells(i, 2) <> .Cells(i + 1, 2) Then
With .Range(.Cells(debCol2_a_Fus, 2), .Cells(i, 2))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
debCol2_a_Fus = i + 1
End If
Next
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Subklin89
re,
@Klin89, je pense que votre macro est le plus rapide et le plus simple
2 petites améliorations
1. Ajouter "Option compare texte" en haut du module pour que les masjuscules et miniscules sont traités ensemble (Italie et italie en B2&B3)
2. Mettez ces "alignements" au début, comme çà, on le fait en une fois et pour toute la plage
Option Explicit
Option Compare Text
Sub Klin89()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim derLig As Long, i As Long, debCol1_a_Fus As Long, debCol2_a_Fus As Long, t
t = Timer
debCol1_a_Fus = 2: debCol2_a_Fus = 2
With Sheets(1) '1ère feuille du classeur
derLig = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(2, 1).Resize(derLig - 1, 2)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
For i = 2 To derLig
If .Cells(i, 1) <> .Cells(i + 1, 1) Then
.Range(.Cells(debCol1_a_Fus, 1), .Cells(i, 1)).Merge
.Range(.Cells(debCol2_a_Fus, 2), .Cells(i, 2)).Merge
debCol1_a_Fus = i + 1
debCol2_a_Fus = i + 1
ElseIf .Cells(i, 2) <> .Cells(i + 1, 2) Then
.Range(.Cells(debCol2_a_Fus, 2), .Cells(i, 2)).Merge
debCol2_a_Fus = i + 1
End If
Next
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub