Autres 2007- Trie et classements de colonnes

[eric57]

Bonjour le Forum

Je reviens vers vous pour un petit souci que je n'arrive pas à régler par moi-même

J'ai au départ 3 colonnes ( Références - Localisation - et Quantités )

Je veux trier mes colonnes pour avoir plus que 1 seule fois chaque référence .

Dans la colonne quantité , j'additionne simplement le nombre totale trouvée pour une référence . Ça je pense réussir a faire.

Mon problème est pour la colonne Localisation, je dois retrouver chaque localisation différente de la même référence, mais aussi la quantité par localisation.


PAr ex CYB-008013 , j'ai 2 lignes avec la même localisation ( J3, je veux donc retrouver J3(2) en colonne localisation

Autre ex, Lignes 38 à 40 , j'ai 3 fois la référence CYB-013482 . Je veux donc retrouver une ligne CYB-013482 avec la localisation : J28(5) - J2(3) et la colonne Qté = 8

J'ai mis un exemple avec en colonne A - B - et C les colonnes tels que je les reçoit au départ , et j'ai mis en H - i - J Ce que je cherche à obtenir.

Merci d'avance à ceux qui pourront m'aider dans ma recherche.

Amicalement à tous

Eric

 

[AtTheOne]

Bonjour à toutes & à tous,
bonjour @eric57

Bon ton sujet n'inspire pas les foules ...

J'ai créé un fonction personnalisée
Localisation(cellule contenant la référence scrutée, plage contenant la liste complète )

J'ai transformé tes listes en tableaux structurés :

Liste	Tableau Complet
Extrait	Tableau avec références uniques

Pour le fun j'ai créé un nom défini qui renvoie les références uniques :

RéfUnique

=SIERREUR( INDEX(Liste[[Référence ]]; PETITE.VALEUR(SI(FREQUENCE(EQUIV(Liste[[Référence ]];Liste[[Référence ]];0);EQUIV(Liste[[Référence ]];Liste[[Référence ]];0))<>0;LIGNE(Liste[[Référence ]])-LIGNE(Liste[#En-têtes]);"");LIGNE()-LIGNE(Extrait[#En-têtes])));"")

Référence unique correspondant à la ligne en cours

Explications :

• FREQUENCE(EQUIV(Liste[[Référence ]];Liste[[Référence ]];0);EQUIV(Liste[[Référence ]];Liste[[Référence ]];0))
  renvoie 0 pour les occurrences de Référence autre que la 1ère
• Si cette 1ère partie de la formule est <>0 on renvoie le N° de la ligne dans le tableau sinon ""
• Pour chaque ligne "n" on prend la nième petite valeur de la liste des N° générée
• Index permet de retourner la Référence correspondant à cette nième petite valeur
• On renvoie "" en cas d'erreur (pour les lignes au delà du nombre de références uniques)

J'ai placé ce nom dans la colonne Référence du tableau Extrait

La colonne Localisation contient l'appel à la fonction personnalisée.

Voir PJ
Bon courage

 

[job75]

Bonjour eric57, AtTheOne,

Je n'avais pas vu passer ce fil, c'est intéressant.

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, dd As Object, tablo, resu(), i&, x$, y$, n&, nn&, z$, p%, q%, v&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
dd.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 3)
For i = 2 To UBound(tablo)
    x = tablo(i, 1): y = x & tablo(i, 2)
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise la ligne
        resu(n, 1) = tablo(i, 1)
    End If
    nn = d(x)
    resu(nn, 3) = resu(nn, 3) + tablo(i, 3)
    If Not dd.exists(y) Then
        dd(y) = ""
        z = resu(nn, 2)
        resu(nn, 2) = IIf(z = "", "", z & " - ") & tablo(i, 2) & "()"
    End If
    y = tablo(i, 2) & "("
    z = resu(nn, 2)
    p = InStr(z, y) + Len(y)
    q = InStr(p, z, ")")
    v = Val(Mid(z, p)) + tablo(i, 3) 'somme des valeurs entre parenthèses
    resu(nn, 2) = Left(z, p - 1) & v & Mid(z, q)
Next
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [H2] '1ère cellule de destination
    If n Then .Resize(n, 3) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

Elle est très rapide car elle utilise des tableaux VBA et 2 Dictionary.

A+

 

[AtTheOne]

Bonsoir @job75,
Comment ça va ?
Je regarde tout à l'heure ton fichier, là je suis pris.
A bientôt

 

[job75]

Pour tester j'ai copié le tableau A2:C51 sur 100 000 lignes.

Chez moi la macro s'exécute en 0,53 seconde.

 

[AtTheOne]

Bonjour @job75
Effectivement ta macro carbure ...
Mais ce n'est pas la même utilisation que la fonction à laquelle on passe la liste source et la référence en argument et donc qui peut être appelée d'une autre feuille, et pour une seule référence.

Elle utilise également un tableau VBA et un dictionnaire, mais le fait de la rendre volatile (ce dont on peut se passer) peut être pénalisant.
Après, l'extraction des valeurs uniques peut se faire par un simple filtre avancé sans doublon. Ma formule est un 'simple' exercice de style ...
A bientôt

 

[eric57]

Bonjour

Merci a vous pour votre implication.

Finalement je suis parti sur la macro de @job75 , plus facile pour moi a intégrer dans la macro finale.

Merci a @AtTheOne pouravoir relancé ce post et permis d'arriver à une solution .

Bonne fêtes de Pâques à tous

 

[AtTheOne]

Bonjour @eric57
Merci pour le retour,
A bientôt

 

[klin89]

Bonjour à tous,

Juste pour le fun, une autre façon de procéder :

Option Explicit
Sub test()
    Dim a, w, e, s, i As Long, n As Long, temp As String
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                dico(a(i, 1)) = VBA.Array(a(i, 1), CreateObject("Scripting.Dictionary"), 0)
            End If
            If Not dico(a(i, 1))(1).exists(a(i, 2)) Then
                dico(a(i, 1))(1)(a(i, 2)) = 0
            End If
            w = dico(a(i, 1))
            w(1)(a(i, 2)) = w(1)(a(i, 2)) + a(i, 3)
            w(2) = w(2) + a(i, 3)
            dico(a(i, 1)) = w
        Next
        n = 1
        For Each e In dico.keys
            n = n + 1
            For Each s In dico(e)(1).keys
                temp = temp & IIf(temp <> "", " - ", "") & s & " (" & dico(e)(1)(s) & ")"
            Next
            a(n, 1) = dico(e)(0)
            a(n, 2) = temp: temp = ""
            a(n, 3) = dico(e)(2)
        Next
        .Offset(, 4).Resize(n, 3) = a
    End With
    Set dico = Nothing
End Sub

klin89

 

[job75]

Bonjour klin89,

C'est intéressant mais moins rapide : 0,80 seconde sur 100 000 lignes.

A+

 

[klin89]

Euh...
Au final, c'est plus simple comme ça

Option Explicit
Sub test()
    Dim a, w, e, s, i As Long, n As Long, temp As String
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                dico(a(i, 1)) = VBA.Array(a(i, 1), CreateObject("Scripting.Dictionary"), 0)
            End If
            w = dico(a(i, 1))
            w(1)(a(i, 2)) = w(1)(a(i, 2)) + a(i, 3)
            w(2) = w(2) + a(i, 3)
            dico(a(i, 1)) = w
        Next
        n = 1
        For Each e In dico.keys
            n = n + 1
            For Each s In dico(e)(1).keys
                temp = temp & IIf(temp <> "", " - ", "") & s & " (" & dico(e)(1)(s) & ")"
            Next
            a(n, 1) = dico(e)(0)
            a(n, 2) = temp: temp = ""
            a(n, 3) = dico(e)(2)
        Next
        .Offset(, 4).Resize(n, 3) = a
    End With
    Set dico = Nothing
End Sub

klin89

 

[job75]

Oui là on arrive à 0,53 seconde, comme au post #5.