XL 2016 Tri tableau sans doublon

[Bruce68]

Bonsoir à tous
Dans le fichier joint j'ai un tableau à 2 dimensions que j'enregistre dans un array.
Ce que je cherche à faire c'est le trier et de supprimer les doublons mais toujours dans le tableau array.
Je vous remercie de votre aide

 

[mapomme]

Bonsoir @Bruce68,

Essayez ce code :

Sub TriSansDoublon()
Dim derlig As Long
   Application.ScreenUpdating = False
   With Sheets("donnees")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(Rows.Count, "a").End(xlUp).Row
      .Columns("d:e").Clear
      .Range("a1").Resize(derlig, 2).Copy .Range("d1")
      With .Range("d1").Resize(derlig, 2)
         .Sort key1:=Range("d1"), order1:=xlAscending, MatchCase:=False, Header:=xlYes
         .RemoveDuplicates 1, xlYes
      End With
   End With
End Sub

edit : bonsoir @job75

 

[job75]

Bonsoir Bruce68, mapomme,

Rien que du très classique :

Option Compare Text 'la casse est ignorée (pour le tri)

Sub Enregistrer_Tableau()
Dim d As Object, tablo, i&, n&, a, b, resu()
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [A1].CurrentRegion.Resize(, 2).Value2 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 1)) = tablo(i, 2)
Next
n = d.Count
If n Then
    a = d.keys: b = d.items
    tri a, b, 0, UBound(a)
    ReDim resu(UBound(a), 1) 'base 0
    '---transposition---
    For i = 0 To UBound(a)
        resu(i, 0) = a(i)
        resu(i, 1) = b(i)
    Next
End If
'---restitution---
With [D2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 2) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Edit : ajouté Option Compare Text (pour le tri)

A+

 

[Dranreb]

Bonsoir.
Ça ressemble tellement à ce qu'on a besoin de préparer pour des ComboBox, et plus rarement pour des ListBox …

 

[Bruce68]

Bonsoir mapomme, job75, dranreb et le forum

Merci beaucoup à vous trois pour votre aide, la macro de job75 et ce que je voulais.
Merci encore et bonne soirée à vous tous

 

[R@chid]

Bonjour @ tous,
pourquoi faire simple quand on peut faire compliqué?
Un essai avec PowerQuery
Il faut juste actualiser la requête à l'ajout des données dans le tableau source.


Cordialement

 

[Bruce68]

Bonsoir R@chid et le forum
C'est excellent mais une petite explication s'impose car je ne vois comment cela fonctionne.
Merci pour l'aise

 

[patricktoulon]

bonsoir à tous
sinon pour les MAChiste ou ceux qui inhibent scripting(donc pas de dico dispo)
une petite fonction de mon cru ,somme toute facile a comprendre (voir commentaire)
la base est un range(...).value
ici en l'occurence sur le fichier joint a la demande c'est
[A1:B2].Resize(Cells(Rows.Count, "A").End(xlUp).Row).Value

Function getaArraySansDoublons(base)
    Dim t(), x&, C1, i&
    C1 = Application.Transpose(Application.Index(base, 0, 1)) '<<1>> represente la colonne par la quelle on fait le filtre des doublons  !!!!!en array a une dimension pour compatibilité avec match!!!!
    For i = LBound(C1) To UBound(C1)
        If Application.Match(C1(i), C1, 0) = i Then 'on recup l'index de la valeur de c1(i) et donc si le match =i alors on le garde
            x = x + 1: ReDim Preserve t(1 To 2, 1 To x): t(1, x) = base(i, 1): t(2, x) = base(i, 2) 'inscription dans variable tableau a 2 dimention dynamique transposée
        End If
    Next
    getaArraySansDoublons = Application.Transpose(t) 'le tableau final transposé
End Function

on teste

Sub test()
    Dim tbl
    tbl = getaArraySansDoublons([A1:B2].Resize(Cells(Rows.Count, "A").End(xlUp).Row).Value)
    [F1].Resize(UBound(tbl), 2) = tbl
End Sub

pour le tri quik sort ok j'ai pas mieux

 

[R@chid]

Bonsoir à tous,

Bonsoir R@chid et le forum
C'est excellent mais une petite explication s'impose car je ne vois comment cela fonctionne.
Merci pour l'aise

Va sur l'onglet : "Données" / Afficher les requêtes
Fais un bouton droit sur la requête / Modifier
Tu trouveras les étapes enregistrées sur PowerQuery.

Cordialement

 

[Jouxte]

Bonjour à toutes et tous,
Dans la solution de mapomme, j'aurais souhaité que l'affichage se fasse dans une autre feuille nommée : Listes en B1
Merci par avance de m'indiquer comment faire.
Bonne journée.

 

[mapomme]

Bonjour @Jouxte

Bonjour à toutes et tous,
Dans la solution de mapomme, j'aurais souhaité que l'affichage se fasse dans une autre feuille nommée : Listes en B1
Merci par avance de m'indiquer comment faire.
Bonne journée.

Voir la macro dans module1 du fichier joint :

Sub TriSansDoublon()
Dim derlig As Long
   Application.ScreenUpdating = False
   Sheets("donnees").Columns("a:b").Copy Sheets("Listes").Columns("b")
   With Sheets("Listes")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(Rows.Count, "b").End(xlUp).Row
      With .Range("b1").Resize(derlig, 2)
         .Sort key1:=.Range("b1"), order1:=xlAscending, MatchCase:=False, Header:=xlYes
         .RemoveDuplicates 1, xlYes
      End With
      Application.Goto .Range("a1"), True
   End With
End Sub

 

[Jouxte]

Bonjour Le Forum,

Merci beaucoup !

Bonne soirée.