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

Shou

XLDnaute Nouveau

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.... :(:

VB:
[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;)
 

Pièces jointes

  • Classeur2.xlsx
    1.7 MB · Affichages: 125
Dernière édition:

eriiic

XLDnaute Barbatruc
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.
VB:
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

XLDnaute Nouveau
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
 

Pièces jointes

  • erreur.PNG
    erreur.PNG
    6.9 KB · Affichages: 68

klin89

XLDnaute Accro
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
Code:
.[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
 
Dernière édition:

laetitia90

XLDnaute Barbatruc
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

VB:
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

XLDnaute Nouveau
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
Code:
.[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

Code:
Len(dict.items()(0))
.

Merci d'avance
 

Shou

XLDnaute Nouveau
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

VB:
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 :D:D:D, votre formule fonctionne !!!!!

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

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 783
Membres
101 817
dernier inscrit
carvajal