XL 2013 Fusionner , Sélectionner et Additionner des doublons via un programme VBA

  • Initiateur de la discussion Initiateur de la discussion Anr1
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Anr1

XLDnaute Occasionnel
Bonjour Forum,

Je sollicite votre aide pour un obstacle en VBA cette fois-ci est un peu compliqué :

1- Colonne "E" fusionner les doublons pour une seul colonne avec:
2-Colonne "K" , si on trouve pour un doublon le mot "connaissance" alors on le laisse et on supprime le mot "malentendu"
3- Colonne de "O" jusqu'au colonne "T" : on additionne les valeurs des doublons .

Ci- joint le fichier avec un exemple de document en"Feuil1" et la solution souhaiter.


Merci d'avance
 

Pièces jointes

Dernière édition:
Bonsoir @anouarlachiri , @Marlysa,

Une piste en VBA. Le code est dans le module de la feuille "Feuil1"
Les résultats sont sur la feuille "Result".
Cliquer sur le bouton Hop!
VB:
Sub test()
Dim derlig&, t, d As New Dictionary, aux, i&, j&, clef, n&

derlig = Cells(Rows.Count, "e").End(xlUp).Row
t = Range("a1:t" & derlig)
d.CompareMode = TextCompare
For i = 1 To derlig
  If Not d.Exists(CStr(t(i, 5))) Then
    ReDim aux(1 To UBound(t, 2))
    For j = 1 To UBound(t, 2): aux(j) = t(i, j): Next j
    d.Add CStr(t(i, 5)), aux
  Else
    aux = d(CStr(t(i, 5)))
    For j = 15 To UBound(t, 2): aux(j) = aux(j) + t(i, j): Next j
    If LCase(t(i, 11)) = "connaissance" Then aux(11) = "Connaissance"
    d(CStr(t(i, 5))) = aux
  End If
Next i

With Worksheets("Result")
  .Activate
  For Each clef In d.Keys
    n = n + 1
    aux = d(clef)
    For j = 1 To UBound(aux): t(n, j) = aux(j): Next
  Next clef
  .UsedRange.Clear
  .Range("a1").Resize(d.Count, UBound(t, 2)) = t
  Worksheets("Feuil1").Range("a2:t2").Copy
  .Range("a2:t2").Resize(n - 1).PasteSpecial xlPasteFormats
  Application.CutCopyMode = False
  .Range("a1:t1").EntireColumn.AutoFit
End With
End Sub
 

Pièces jointes

Pourquoi vouloir du VBA? C'est faisable par des formules ou Un simple tableau croisé dynamique.

Quelques axes de solutions possibles ...
Pour les valeurs texte n'ayant pas compris la logique, je ne sais pas répondre.



Merci bcp pour votre réactivité,

J'aurais besoin de garder les informations dans les autres colonne ( A,B,C...) correspondant a mes colonnes fusionner et aussi besoin de garder la même format de tableau ...
 
Bonsoir @anouarlachiri , @Marlysa,

Une piste en VBA. Le code est dans le module de la feuille "Feuil1"
Les résultats sont sur la feuille "Result".
Cliquer sur le bouton Hop!
VB:
Sub test()
Dim derlig&, t, d As New Dictionary, aux, i&, j&, clef, n&

derlig = Cells(Rows.Count, "e").End(xlUp).Row
t = Range("a1:t" & derlig)
d.CompareMode = TextCompare
For i = 1 To derlig
  If Not d.Exists(CStr(t(i, 5))) Then
    ReDim aux(1 To UBound(t, 2))
    For j = 1 To UBound(t, 2): aux(j) = t(i, j): Next j
    d.Add CStr(t(i, 5)), aux
  Else
    aux = d(CStr(t(i, 5)))
    For j = 15 To UBound(t, 2): aux(j) = aux(j) + t(i, j): Next j
    If LCase(t(i, 11)) = "connaissance" Then aux(11) = "Connaissance"
    d(CStr(t(i, 5))) = aux
  End If
Next i

With Worksheets("Result")
  .Activate
  For Each clef In d.Keys
    n = n + 1
    aux = d(clef)
    For j = 1 To UBound(aux): t(n, j) = aux(j): Next
  Next clef
  .UsedRange.Clear
  .Range("a1").Resize(d.Count, UBound(t, 2)) = t
  Worksheets("Feuil1").Range("a2:t2").Copy
  .Range("a2:t2").Resize(n - 1).PasteSpecial xlPasteFormats
  Application.CutCopyMode = False
  .Range("a1:t1").EntireColumn.AutoFit
End With
End Sub


Bonjour @mapomme ,
Meeerci bcp c'est vraiment un "Hop"pour moi lol
votre programme marche parfaitement sur le dossier Test , je vais tenter ma chance sur mon dossier et je reviens vers vous au plus vite possible 😉
 
Rebonjour @mapomme,

Voilà le probléme que j'ai eu , c'est dans la première ligne "Dim derlig&, t ,d As New dictionary, aux,i&,j&,clef,n&"
Il faut fair quoi à votre avis

NB : presque 20000 lignes.

Votre programme est très bien et ça fonctionne parfaitement sur le fichier TEST je peux arriver a résoudre mon problème avec vous ..
Merci d'avance 🙂
 

Pièces jointes

  • doublon.PNG
    doublon.PNG
    92.5 KB · Affichages: 10
Dernière édition:
Re @anouarlachiri,

Bizarre. Êtes vous bien sur Excel Windows ? (et non MAC)

Essayez la version v2. J'ai remplacé la définition de l'objet d au niveau de la déclaration par une déclaration "tardive" (instruction);

En début de code :
Au lieu de :
VB:
Sub test()
Dim derlig&, t, d As New Dictionary, aux, i&, j&, clef, n&

derlig = Cells(Rows.Count, "e").End(xlUp).Row
t = Range("a1:t" & derlig)
d.CompareMode = TextCompare

on a codé :
VB:
Sub test()
Dim derlig&, t, d, aux, i&, j&, clef, n&

derlig = Cells(Rows.Count, "e").End(xlUp).Row
t = Range("a1:t" & derlig)
Set d = CreateObject("scripting.dictionary")
d.CompareMode = TextCompare
 

Pièces jointes

@mapomme

Oui j'ai Excel Windows et j'ai essayé votre deuxième code et ça marche très bien comme je voulais exactement juste que le premier doublon est au colonne "k" ligne 4 et 5 le programme ils prend pas que le mont "connaissance " il a pris le mot " malentendu" et quelques autres observations je sait pas pourquoi .... cette condition est pas tjrs respecter
 
Re,

Dans ma version v1 et v2, j’avais écrit :
VB:
If LCase(t(i, 11)) = "connaissance" Then aux(11) = "Connaissance"
avec un "c" minuscule pour la première lettre du premier mot "connaissance"

Dans votre version Test_verifier1.xlsm, on trouve à la place cette instruction :
VB:
If LCase(t(i, 11)) = "Connaissance" Then aux(11) = "Connaissance"
avec un "C" MAJUSCULE pour la première lettre du premier mot "connaissance"

C'est ce qui explique le comportement bizarre de votre version.
 
@mapomme,

Je me permets de vous demandez si c'est possible de m’écrire des commentaire sur le programme pour que je puisse le comprendre mieux.

NB: je suis débutant en VBA alors juste pour améliorer mon niveau si vous pouvez m'aider et si c'est possible bien sur 🙂
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour