Macro détéctant fusionnant cellules identiques.

[Marc T]

Bonjour,

Je continue de me former un peu plus sur Excel tout les jours mais j'avoue buter sur les macros. Mes connaissances se limitent donc à l'essentiel.

En effet, je travaille sur des tableaux faisant plusieurs milliers de lignes et afin de faciliter leur lecture, j'aimerai pouvoir exécuter une macro capable de détecter les céllules identiques dans une colonne A, B, C etc... et surtout capable de fusionner les valeurs identiques en une seule.

Je ne pense pas que cela soit si compliqué, mais voilà je ne trouve pas, alors je m'en remets à vous en espérant que vous pourrez m'aider sur ce sujet.

Merci d'avance pour votre aide et vos conseils.

Cordialement,

Marc.

PS: La version d'excel est la 2000 et je travaille sous PC.

 

[Yoyo]

Salut marc


Cette macro à l'ai de fonctionner pour la fusion des cellule ABCn si elle sont identique parcontre cette macro fusionne aussi les cellule ABCn si elle vide

Cordialement yoyo


Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 06/02/2006 par ADSLHY
'

'
Application.ScreenUpdating = False 'fige l'affichage de l'écran
Application.EnableEvents = False 'Supprime certain message d'alerte windows


For i = 2 To 10 'choisissez de quelle ligne a quel ligne doit ce faire les fusion

'C1 & C2 sont les condition qui permettent de savoir si An=Bn et si Bn=Cn
C1 = Range('A' & i) = Range('B' & i)
C2 = Range('B' & i) = Range('C' & i)

If (C1 = True And C2 = True) Then 'si C1 et C2 sont vrai alors fusion cellule ABCn
Range('B' & i, 'C' & i).Select
Selection.ClearContents
Range('A' & i, 'C' & i).Select 'selection An;Cn
With Selection 'fusion
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
End If
Next i
Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub

 

[Marc]

Merci beaucoup!!!

Je l'essaye dès que je peux et vous tiens au courant.

Encore merci pour le coup de main.


PS: Etant novice dans le domaine des macros, y a t'il quelquechose que je dois changer dans les lignes que vous avez indiqué afin de pouvoir utiliser la macro?

 

[PièceJointe]

Re : Macro détéctant fusionnant cellules identiques.

Bonjour à tous...

Tout d'abord je suis impressionné par ce forum...bravo...

Mon problème est sensiblement le même...pour commencer...après tout ce complique évidemment...

je souhaite fusionner automatiquement des cellules identiques dans des colonnes identifiées (c'est à dire uniquement dans les colonnes de mon choix : ici les colonnes F K et M et uniquement pour des cellules adjacentes verticalement).

En cadeau bonux, s'il était possible, je souhaiterai que cela se fasse dans une autre feuille afin de conserver la possibilité de trier et de calculer comme bon me semble dans le fichier "source"...

Je précise que je ne sais pas faire de macro car j'imagine que c'est ce qui va poindre...

Merci d'avance, En Pièce Jointe un exemple de ce sur quoi je travaille...anonymé et réduit à quelques lignes...

Merci de vos conseils...

 

[PièceJointe]

Re : Macro détéctant fusionnant cellules identiques.

Bon comme mon pb est assez urgent j'ai testé, en vu éventuellement de m'appuyer dessus (ce qui est je l'avoue très présomptueux de ma part) la macro gentiment postée ci-dessus...mais impossible de l'exécuter...

Visiblement il y a une (je cite) "erreur de compilation /erreur de syntaxe" à la ligne :
C1 = Range('A' & i) = Range('B' & i)

Une idée ?

Merci d'avance...

 

[PièceJointe]

Re : Macro détéctant fusionnant cellules identiques.

hello,

je me réponds à moi-même

voici ce que j'ai toruvé ailleurs


'Mes valeurs sont dans la colonne A
Dim Deb As Long

Range("A1").Select
Application.DisplayAlerts = False
Deb = -1
While Not IsEmpty(ActiveCell)
If ActiveCell.Value = ActiveCell.Offset(1).Value Then
If Deb = -1 Then Deb = ActiveCell.Row
Else
If Deb <> -1 Then
With Range("A" & Deb & ":A" & ActiveCell.Row)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
Deb = -1
End If
End If
ActiveCell.Offset(1).Select
Wend
Application.DisplayAlerts = True


ça ne marche pas plus...

HELPPPPP ! Y a t' il quelqu'un dans la salle qui pourrait me sauver... ? je sens que je vais y passer ma fin de semaine...