XL 2013 un dictionnaire qui ne fonctionne pas- listbox sans doublons (source tableau structuré)

[patricktoulon]

Bonjour a tous
j'ai fait un tout petit exemple pour un membre sur 2007
ayant enfin réparé mon pc je suis sur 2013
et là c'est la confusion totale dans mon esprit le dico ne fonctionne pas quand je prends pas la colonne 1 du tableau
je met des témoins et même un msgbox pour m'afficher le compte rendu du job
pas moyen les doublons sont gardés

je suis assez désappointé
une capture du résultat avec la colonne 1("prenom")

capture du resultat avec la colonne 2 ("nom")

ci joint un classeur avec 2 petit tableaux structurés et 3 petit userforms pour l'exemple
l'exemple 1 et 2 tri les doublons sur une colonnes (quand c'est pas la colonne 1 ca ne fonctionne pas)
l'exemple 3 lui tri sur les valeurs de la ligne entière il fonctionne

 

[Compte Supprimé 979]

Salut Patrick

Effectivement il y a un souci si on prend la colonne nom et je rassure toi, je ne vois pas non plus pourquoi

Tellement plus simple avec une collection

Function GetTableNoDouble(rng As Range, Optional colMaitre As Variant = 1, Optional vertical As Boolean = False)
  Dim a&, i&, Unique As New Collection, tbl(), tablo, c&, z
  tablo = rng.Value
  texte = "colonne controlée :colonne(""" & colMaitre & """)"""
  If Not IsNumeric(colMaitre) Then colMaitre = Range(rng.ListObject.Name).ListObject.ListColumns(colMaitre).Index
  On Error Resume Next
  For i = 1 To UBound(tablo)
    texte = texte & vbCrLf & tablo(i, colMaitre) & ";  "
    z = " ligne du tableau " & i & ":   non gardé"
    Unique.Add i, CStr(tablo(i, colMaitre))
    If Err.Number = 0 Then
      z = " ligne du tableau " & i & ":   gardé"
      'comme on redim preserve et que seul la derniere dimmension est redimentionnable alors on redim transposé
      a = a + 1: ReDim Preserve tbl(1 To UBound(tablo, 2), 1 To a)
      For c = 1 To UBound(tablo, 2): tbl(c, a) = tablo(i, c): Next
    Else
      Err.Clear
    End If
    texte = texte & z
  Next
  On Error GoTo 0
  GetTableNoDouble = tbl
End Function

A+

 

[patricktoulon]

bonjour bruno
oui aussi mais j’aimerais bien résoudre l’énigme du problème du dico
car pour moi il n'y a aucune raison c' est un truc vraiment bizarre
j'ajoute le modèle collection dans mon fichier
c'est pour distribuer en tant qu'exemple aux demandes similaires

l'énigme est toujours a résoudre dans les userforms exemple(1 et 2)

 

[Compte Supprimé 979]

Re,

Arff, je crois avoir trouvé

Le souci se situe sur cette ligne

      dico(tablo(i, 1)) = ""    ' le dico sert juste a controler on ne se sert pas de son .keys ou .items

Tu ne tiens pas compte de la colonne maitre

A remplacer par

      dico(tablo(i, colMaitre)) = ""    ' le dico sert juste a controler on ne se sert pas de son .keys ou .items

Voilà en entier

Function GetTableNoDouble(rng As Range, Optional colMaitre As Variant = 1, Optional vertical As Boolean = False)
  Dim a&, i&, dico As Object, tbl(), tablo, c&, z
  tablo = rng.Value
  texte = "colonne controlée :colonne(""" & colMaitre & """)"""
  Set dico = CreateObject("scripting.dictionary")
  If Not IsNumeric(colMaitre) Then colMaitre = Range(rng.ListObject.Name).ListObject.ListColumns(colMaitre).Index
  For i = 1 To UBound(tablo)
    texte = texte & vbCrLf & tablo(i, colMaitre) & ";  "
    z = " ligne du tableau " & i & ":   non gardé"
    If Not dico.exists(tablo(i, colMaitre)) Then
      dico(tablo(i, colMaitre)) = ""    ' le dico sert juste a controler on ne se sert pas de son .keys ou .items
      z = " ligne du tableau " & i & ":   gardé"
      'comme on redim preserve et que seul la derniere dimmension est redimentionnable alors on redim transposé
      a = a + 1: ReDim Preserve tbl(1 To UBound(tablo, 2), 1 To a)
      For c = 1 To UBound(tablo, 2): tbl(c, a) = tablo(i, c): Next
    End If
    texte = texte & z
  Next
  GetTableNoDouble = tbl
End Function

Ca semble fonctionner chez moi

Code excellent, pas étonné venant de ta part hop je mets dans ma bibliothèque de codes

@+

 

[patricktoulon]

re
pas vrai !!! j'ai fait cette boulette!!???
et moi je cherche depuis plus d'une heure
purée là!!... j'ai vraiment honte

ben je vais me recoucher tient voilà
merci bruno

 

[Compte Supprimé 979]

Comme quoi ça peut arriver, même aux meilleurs

C'est ça de faire des sup la nuit une barre de mars et ça repart

Bonne nuit alors

 

[patricktoulon]

Bon après un petit déjeuné a ma taille

bruno prend plutôt cet exemple il est complet
dans l'appel on a la possibilité de l'appeler et de recevoir un tableau vertical
ca peut servir selon le besoins

Private Sub CommandButton1_Click()
    Dim tbl, table As Range
    Set table = Range("Tableau1")
    'en 2d argument soit l'index soit le nom de la colonne (dans le header)
    ' en 3e argument true ou false si on le veut vertical ou horizontal
    ' tbl = GetTableNoDouble(table, "prenom")
    tbl = GetTableNoDouble(table, "nom")
    With ListBox1
        .ColumnCount = table.Columns.Count
        ' si on a omis ou mis le 3e argument "vertical" a false  c'est un tableau transposé on utilise ".Column" et non ".list"
        ' sinon on utilise ".List"
        .Column = tbl
    End With
    MsgBox texte
End Sub

Function GetTableNoDouble(rng As Range, Optional colMaitre As Variant = 1, Optional vertical As Boolean = False)
    Dim a&, i&, dico As Object, tbl(), tablo, c&, z
    tablo = rng.Value
    texte = "colonne controlée :colonne(""" & colMaitre & """)"""
    Set dico = CreateObject("scripting.dictionary")
    If Not IsNumeric(colMaitre) Then colMaitre = Range(rng.ListObject.Name).ListObject.ListColumns(colMaitre).Index
    For i = 1 To UBound(tablo)
        texte = texte & vbCrLf & tablo(i, colMaitre) & ";  "
        z = " ligne du tableau " & i & ":   non gardé"
        If Not dico.exists(tablo(i, colMaitre)) Then
            dico(tablo(i, colMaitre)) = ""    ' le dico sert juste a controler on ne se sert pas de son .keys ou .items
            z = " ligne du tableau " & i & ":   gardé"
            'comme on redim preserve et que seul la derniere dimmension est redimentionnable alors on redim transposé
            a = a + 1: ReDim Preserve tbl(1 To UBound(tablo, 2), 1 To a)
            For c = 1 To UBound(tablo, 2): tbl(c, a) = tablo(i, c): Next
        End If
        texte = texte & z
    Next
    If vertical Then tbl = Application.Transpose(tbl)
    GetTableNoDouble = tbl
End Function

et le tiens avec la collection

Option Explicit

Dim texte
Private Sub CommandButton1_Click()
    Dim tbl, table As Range
    Set table = Range("Tableau1")
    ' si on a omis ou mis le 3e argument "vertical" a false  c'est un tableau transposé on utilise ".Column" et non ".list"
        ' sinon on utilise ".List"
      ' tbl = GetTableNoDouble(table, "prenom")    'en 2d argument soit l'index soit le nom de la colonne (dans le header)
    tbl = GetTableNoDouble(table, "nom", True)   'en 2d argument soit l'index soit le nom de la colonne (dans le header)
    With ListBox1
        .ColumnCount = table.Columns.Count
         ' si on a omis ou mis le 3e argument "vertical" a false  c'est un tableau transposé on utilise ".Column" et non ".list"
        ' sinon on utilise ".List"
        '.Column = tbl
        .List = tbl
        End With
    MsgBox texte
End Sub
Function GetTableNoDouble(rng As Range, Optional colMaitre As Variant = 1, Optional vertical As Boolean = False)
'utilisation d'une collection 'by Bruno45
    Dim a&, i&, Unique As New Collection, tbl(), tablo, c&, z
    tablo = rng.Value
    texte = "colonne controlée :colonne(""" & colMaitre & """)"""
    If Not IsNumeric(colMaitre) Then colMaitre = Range(rng.ListObject.Name).ListObject.ListColumns(colMaitre).Index
    On Error Resume Next
    For i = 1 To UBound(tablo)
        texte = texte & vbCrLf & tablo(i, colMaitre) & ";  "
        z = " ligne du tableau " & i & ":   non gardé"
        Unique.Add i, tablo(i, colMaitre)
        If Err.Number = 0 Then
            z = " ligne du tableau " & i & ":   gardé"
            'comme on redim preserve et que seul la derniere dimmension est redimentionnable alors on redim transposé
            a = a + 1: ReDim Preserve tbl(1 To UBound(tablo, 2), 1 To a)
            For c = 1 To UBound(tablo, 2): tbl(c, a) = tablo(i, c): Next
        Else
            Err.Clear
        End If
        texte = texte & z
    Next
    On Error GoTo 0
    If vertical Then tbl = Application.Transpose(tbl)
    GetTableNoDouble = tbl
End Function