Autres 2007- Trie et classements de colonnes

eric57

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

Pièces jointes

  • Forum-Trie-ref.xlsx
    16.5 KB · Affichages: 13
Solution
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 :
VB:
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...

AtTheOne

XLDnaute Accro
Supporter XLD
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 :
ListeTableau Complet
ExtraitTableau 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
 

Pièces jointes

  • Forum-Trie-ref.xlsm
    23.6 KB · Affichages: 5

job75

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

Pièces jointes

  • Forum-Trie-ref(1).xlsm
    22.5 KB · Affichages: 11
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
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.
1680866958545.png


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
 
Dernière édition:

klin89

XLDnaute Accro
Bonjour à tous, 🙂

Juste pour le fun, une autre façon de procéder :
VB:
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
 

klin89

XLDnaute Accro
Euh...
Au final, c'est plus simple comme ça 🙄
VB:
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
 

Discussions similaires

Réponses
36
Affichages
2 K

Statistiques des forums

Discussions
313 271
Messages
2 096 724
Membres
106 720
dernier inscrit
Alain EDZOA