Fusionner les cellules identidiques et concatener les informations sans doublons ( VBA)

[Shou]

Hello !!


J'ai besoin d'aide sur un fichier . J'ai posté ma demande sur une discussion. Mais un utilisateur m'a dit qu'il valait mieux créer un post. Me voici donc🙂


J'ai essayer d'adapter la macro donnée dans cette conversation mais sans succès.... 🙁:

[I]Sub concatenerdoublons()


Dim i As Long

Dim chaine As Variant

For i = 1 To Range("F1").End(xlDown).Row

  If WorksheetFunction.CountIf(Range("L:M"), "=" & Cells(i, 1).Value) = 1 Then

  chaine = Range("L:L").Find(What:=Cells(i, 1).Value, After:=Range("L1"), LookIn:=xlFormulas, LookAt _

  :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _

  False, SearchFormat:=False).Offset(0, 1) & " / " & Cells(i, 6)

  Range("L:L").Find(What:=Cells(i, 1).Value, After:=Range("L1"), LookIn:=xlFormulas, LookAt _

  :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _

  False, SearchFormat:=False).Offset(0, 6) = chaine

  Else

  If IsEmpty(Range("L1")) Then

  Range("L65536").End(xlUp) = Cells(i, 1)

  Range("M65536").End(xlUp) = Cells(i, 6)

  Else

  Range("L65536").End(xlUp).Offset(1, 0).Value = Cells(i, 1)

  Range("M65536").End(xlUp).Offset(1, 0).Value = Cells(i, 6)

  End If

  End If
Next i

End Sub[/I]

Je chercher à ce que tous les doublons des références soit supprimé et avoir en face les lignes correspondantes concatener


Je m'explique:


Dans l'onglet "Extract "du fichier excel ce trouve une extraction d'un logiciel.

Une même référence peut se trouver sur plusieurs lignes.

J'ai donc des références en doublons parfois jusqu'à 30 fois la même référence n'étant pas pour le même module et pouvant être sur plusieurs lignes de montage (A,B,C,F...).


J'aimerais dans un nouvel onglet pouvoir retrouver une seule fois cette référence avec les lignes concatener dans la colonne à côté ( cf onglet "Nouveau" dans le fichier excel)

J'oublais, les références ne sont pas triées par ordre croissant on peux trouver une référence dans la première ligne excel puis ensuite dans la 68000ème ligne.


Je ne sais pas si c'est clair. J'essaye depuis deux jours. J'ai vraiment besoin de votre aide.


Merci d'avance😉

 

[eriiic]

Bonjour,

évite les espaces en fin de nom d'onglet, j'ai supprimé celui de "Nouveau ".
Quand tu mets un code, indente-le et utilise la balise Code sinon on lit pas et éventuellement on passe à une autre demande.

Sub compile()
    Dim datas, dict
    Dim lig    As Long
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets("EXTRACT")
        datas = .[A2].Resize(.Cells(Rows.Count, 1).End(xlUp).Row - 1, 11).Value
    End With
    For lig = 1 To UBound(datas)
        If dict.exists(datas(lig, 6)) Then
            dict(datas(lig, 6)) = dict(datas(lig, 6)) & "/" & datas(lig, 11)
        Else
            dict(datas(lig, 6)) = datas(lig, 11)
        End If
    Next lig
    With Sheets("Nouveau")
        .[A1].CurrentRegion.Offset(1).ClearContents
        .[A2].Resize(dict.Count, 1) = Application.Transpose(dict.keys)
        .[B2].Resize(dict.Count, 1) = Application.Transpose(dict.items)
        .Activate
    End With
End Sub

limité à 64000 ref...
eric

 

[Shou]

Bonjour,

Super merci pour ce retour.

Je ne savais pas qu'il y avait une balise code .

Je viens d'essayer votre Macro mais un code erreur apparaît.

Merci d'avance

 

[eriiic]

Bonjour,

Pas chez moi sur ton classeur de test. Et si c'est passé avec dict.keys, étrange que ça ne passe pas avec dict.items
Quel code erreur ?
eric

 

[gosselien]

Bonjour

ça va être difficile de faire des calculs, la colonne H ("QTY") est en texte (espace avant le nombre)

P.

ps: pas d'erreur chez moi sauf celle due à l'espace en fin de nom de l'onglet

 

[Shou]

Bonjour

ça va être difficile de faire des calculs, la colonne H ("QTY") est en texte (espace avant le nombre)

P.

ps: pas d'erreur chez moi sauf celle due à l'espace en fin de nom de l'onglet

Bonjour,

Je ne pouvais avoir accès à internet plus tôt.

Je viens d'essayer en enlevant l'espace dans la colonne quantity avant le nombre.

J'avais également pour la colonne ligne une formule qui déterminait la ligne j'ai copié en valeur.

Je ne vois pas d'où peut venir l'erreur . J'ai 58000 lignes dans mon fichier donc je ne dépasse pas la limite .

L'erreur qui s'affiche est en pièce jointe à ce commentaire.

Merci d'avance

 

[klin89]

Bonjour à tous, 🙂

Pour connaitre le nombre de caractères d'un item, j'ai placé un espion :

Len(dict.items()(0))

dès que la limite des 255 caractères a été dépassée, la ligne suivante a bugué sous Excel2003

.[B2].Resize(dict.Count, 1).Value = Application.Transpose(dict.items)

Donc, dans ton cas, pour une seule et même occurrence en colonne F, cela bug dès 129 lignes dans le tableau source
128 ça passe.

klin89

 

[laetitia90]

bonjour tous 🙂
une autre facon de l'ecrire dans l'ordre alpha... sans doublons pour les valeurs concatenées
on evite application transpose.... je prends le code_name des feuilles plus simple

Sub es()
  Dim t(), i As Long, m As Object, x As Long
Application.ScreenUpdating = 0
With Feuil2
Feuil1.Range("f:f, k:k").Copy Feuil2.[A1]
  .[A1].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
.[A1].CurrentRegion.Sort key1:=.[A1], order1:=xlAscending, _
  key2:=.[b1], order2:=xlAscending, Header:=xlYes, MatchCase:=0
     Set m = CreateObject("Scripting.Dictionary")
      t = .Range("a2:b" & .Cells(Rows.Count, 1).End(3).Row)
      For i = 1 To UBound(t)
      If m.exists(t(i, 1)) Then
      t(m(t(i, 1)), 2) = t(m(t(i, 1)), 2) & "/" & t(i, 2)
      Else
      x = x + 1
      t(x, 1) = t(i, 1): t(x, 2) = t(i, 2): m(t(i, 1)) = x
      End If
      Next i
   .Range("a2:b" & .Cells(Rows.Count, 1).End(3).Row).ClearContents
   .[A2].Resize(x, 2) = t
End With
End Sub

a voir!!!

 

[Shou]

Bonjour à tous, 🙂

Pour connaitre le nombre de caractères d'un item, j'ai placé un espion :

dès que la limite des 255 caractères a été dépassée, la ligne suivante a bugué sous Excel2003

.[B2].Resize(dict.Count, 1).Value = Application.Transpose(dict.items)

Donc, dans ton cas, pour une seule et même occurrence en colonne F, cela bug dès 129 lignes dans le tableau source
128 ça passe.

klin89

Bonjour,

Je pense que l'erreur viens effectivement que l'occurence de la colonne F survient parfois plus de 129 fois.

Comment puis-je appliquer votre formule

Len(dict.items()(0))

.

Merci d'avance

 

[Shou]

bonjour tous 🙂
une autre facon de l'ecrire dans l'ordre alpha... sans doublons pour les valeurs concatenées
on evite application transpose.... je prends le code_name des feuilles plus simple

Sub es()
  Dim t(), i As Long, m As Object, x As Long
Application.ScreenUpdating = 0
With Feuil2
Feuil1.Range("f:f, k:k").Copy Feuil2.[A1]
  .[A1].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
.[A1].CurrentRegion.Sort key1:=.[A1], order1:=xlAscending, _
  key2:=.[b1], order2:=xlAscending, Header:=xlYes, MatchCase:=0
     Set m = CreateObject("Scripting.Dictionary")
      t = .Range("a2:b" & .Cells(Rows.Count, 1).End(3).Row)
      For i = 1 To UBound(t)
      If m.exists(t(i, 1)) Then
      t(m(t(i, 1)), 2) = t(m(t(i, 1)), 2) & "/" & t(i, 2)
      Else
      x = x + 1
      t(x, 1) = t(i, 1): t(x, 2) = t(i, 2): m(t(i, 1)) = x
      End If
      Next i
   .Range("a2:b" & .Cells(Rows.Count, 1).End(3).Row).ClearContents
   .[A2].Resize(x, 2) = t
End With
End Sub

a voir!!!

Bonjour,

Merci beaucoup 😀😀😀, votre formule fonctionne !!!!!

Depuis le temps que je recherche une solution ! Merci beaucoup pour votre aide à tous 🙂