Liste sans doublon àpd tableau

Bonjour à tous,

Je suis à la recherche d'une formule permettant de lister dans une colonne les valeurs uniques (donc sans doublon) d'un tableau.

J'ai beau rechercher dans le forum et retourner le problème dans tous les sens, je sèche. Je suis déjà parvenu à extraire les données uniques d'une colonne avec la formule de Jacques Boigontier (http://boisgontierjacques.free.fr/pages_site/sommeprod.htm#ListeSansDoublons), mais je ne parviens pas à transposer dans le cadre d'un tableau.

Une idée ?

Bonjour,

Peut-etre faut-il que tu définisses ton tableau comme matrice de recherche?

Avec un fichier joint, on y verrais plus clair.

Cordialement,

Leakim

Voilà un fichier type qui illustre mon souhait. La colonne M devrait pouvoir lister l'ensemble des éléments uniques inclus dans le tableau. Ca n'a pas l'air sorcier en théorie, mais en pratique, c'est l'impasse.

Bonsoir,

1er. jus avec VBA.

Pour lancer la procédure CTRL+Q.

Bonsoir Jean-Eric,

Merci beaucoup, ça marche au poil ! Toutefois, j'avais omis de préciser que je souhaiterais que cette opération se fasse de manière automatique car elle fait partie d'une suite plus importante d'opérations et de traitement de données. Le fichier sur lequel je travaille est en fait une sorte de tableau de bord puisant dans une série d'autres fichiers. Il sera plus pratique pour l'utilisateur final de n'avoir qu'à ouvrir le fichier et directement pouvoir analyser les données.

Est-ce beaucoup demander ?

Re,

Dans le module ThisWorkbook, du classeur,insérer cette procédure :

Option Explicit
Private Sub Workbook_Open()
    ListeSansDoublons
End Sub

La procédure sera lancer à l'ouverture du classeur.

Cdlt

Re;

La procédure sera lancée à l'ouverture du classeur

Cdlt.

bonjour bonjour leakim

un essai par formule matricielle ( validation par Ctrl maj Entrée : les 3 touches en meme temps )

cordialement

Rebonjour à vous deux,

Un essai avec une formule matricielle tirée du site que tu as donné plus haut.

=SI(LIGNES($1:1)<=NBVAL(champ);INDEX(champ;MOD(PETITE.VALEUR(SI(champ<>"";COLONNE(champ)*10^5+
LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1));10^5);ENT(PETITE.VALEUR(SI(champ<>"";COLONNE(champ)*10^5+
LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1))/10^5)-COLONNE(champ)+1);"")

A valider avec Ctrl+MAJ=Entrée

Si tu incrémentes sur suffisamment de ligne, la mise à jour ce fera d'elle même.

Petit bémol, pour avoir utilisé une formule de tri en matricielle sur plus de 500 lignes, excel RAME et ton fichier gonfle en volume d'octet. La VBA reste alors une solution beaucoup plus légère. Bien que la plus-value de cette formule soit le classement alphabétique !

Cordialement,

Leakim

Salutations tulipe_4

J'étais absorbé à rédiger, lorsque je me suis rendu compte de ta proposition, qui m'est plus accessible que celle que j'ai copier/coller du site.

Encore une fois plusieurs façons de résoudre un problème.

Re,

Ci-dessous le code de mon précédent post.

Pour information.

Cdlt

Option Explicit
Sub ListeSansDoublons()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("B3:K22")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [M3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub

Merci à tous de vous être penchés sur mon cas. C'est vraiment très gentil à vous.

J'ai essayé plusieurs de vos solutions.

• La macro de Jean-Eric fonctionnait très bien avec le raccourci Ctrl+q, mais je ne suis jamais parvenu à la rendre automatique. Il y a apparemment une ligne de code à déboguer.
• La formule matricielle de Leakim ne m'a donné aucun résultat concluant. Je ne suis certainement pas arrivé à l'exploiter correctement.
• La formule de tulipe_4 m'a paru plus accessible. C'est celle avec laquelle je suis le plus à l'aise. Malheureusement là encore (je suis irrécupérable ), je n'obtiens aucun résultat lorsque je la transpose dans mon fichier.

Aussi, je vous joins l'original sur lequel je travaille. Ce sera plus parlant pour tout le monde. Il y a encore un morceau du code VBA de Jean-Eric adapté par mes soins pour prendre en compte les bonnes cellules et dans la colonne EI, la formule de tulipe_4.

Le fichier est censé puiser ses données dans d'autres fichiers. Il vous demandera de mettre à jour à l'ouverture. Ignorez cette étape.

Je sens qu'on approche du but !

Re,

Dans ton fichier, toutes les cellules sont égales à 0 (référence à un autre classeur).

Ensuite, tu n'as pas suivi mes consignes quant à l'insertion du code ci-dessous dans "ThisWorkbook"

Option Explicit
Private Sub Workbook_Open()
    ListeSansDoublons
End Sub
 

Je joins ton fichier modifié pour test.

Cdlt.

Rebonjour et pardon pour le temps de réponse.

Jean-Eric, effectivement ton code VBA marche très bien. Merci infiniment! Est-il en revanche possible de répéter l'opération pour plusieurs parties d'un tableau de la même page ?

Je m'explique : le code VBA permet d'extraire les projets uniques réalisés au cours d'un mois x. Je souhaiterais que cette opération puisse être également effectuée pour d'autres mois y, z, a, b, c .... Mon fichier avec macro étant trop lourd, j'ai mis en annexe un fichier qui reprend la même structure.

J'ai tenté naïvement un copier/coller de ton code comme suit, mais sans succès.

Option Explicit
Sub ListeSansDoublons()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW3:ET22")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsAugust()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW23:ET42")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV23].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsSeptember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW43:ET62")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV43].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsOctober()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW63:ET82")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV63].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsNovember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW83:ET102")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV83].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsDecember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW103:ET122")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV103].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub

C'est promis après, je vous fous la paix

Bonsoir,

A vue de nez, je modifierai les colonnes de retour [EVxx] pour chaque procédure

A moins d'être certain de ne pas avoir + 20 valeurs par liste sans doublons.

Cdlt

[EV23].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

Bonjour,

A vue de nez, je modifierai les colonnes de retour [EVxx] pour chaque procédure

N'est-ce pourtant pas ce que j'ai fait en passant de EV3 à EV23, puis EV43... ?

Serait-ce l'élément "Option Explicit" que je devrais répéter pour chaque procédure? Je l'avais fait initialement, mais Excel a lancé la commande de débogage en me le mettant en évidence.

Bien à toi,

Bonjour,

1 - "Option explicit" est à placer une seule fois à la première ligne du module.

2 - Tu ne connais pas le nombre de valeurs des tes listes et tu utilises toujours la même colonne "EV" pour tes résultats. Mets tes listes en EV, puis EW, etc...,

A te relire. Cdlt

Je comprends bien la logique de ton point 2 (très judicieux). En effet, c'est plus viable de présenter l'information de cette manière. J'ai donc restructuré mes listes sans doublon en plusieurs colonnes. Dans la foulée, j'ai adapté mon code VBA comme suit pour respecter la nouvelle configuration. L'espace laissé entre les colonnes de listes sans doublon s'explique par le besoin d'une colonne intermédiaire. Mes listes apparaissent donc sur les colonnes EV3:..., EX3:..., EZ3:..., etc ... Malheureusement, seule la première procédure en EV3:... s'exécute.

EDIT: Je pense à ça... Est-ce que le nom de la procédure a une quelconque importance ??

Option Explicit
Sub ListeSansDoublons()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW3:ET22")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EV3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsAugust()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW23:ET42")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EX3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsSeptember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW43:ET62")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [EZ3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsOctober()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW63:ET82")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [FB3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsNovember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW83:ET102")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [FD3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub
Sub ListeSansDoublonsDecember()
Dim wS As Worksheet
Dim monDico
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    Set monDico = CreateObject("Scripting.Dictionary")
    For Each c In wS.Range("CW103:ET122")
        If c <> "" Then monDico(c.Value) = ""
    Next c
    [FF3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)

    Set wS = Nothing: Set monDico = Nothing

End Sub

RE,

Ci dessous code modifié qui prend en charge les plages cellules vides

Cdlt

Option Explicit
Sub ListeSansDoublons()
Dim wS As Worksheet
Dim monDico
Dim Plage As Range
Dim c As Range

    Application.ScreenUpdating = False
    Set wS = Worksheets(1)
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW3:ET22")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
    End If
    [EV3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW23:ET42")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
        [EX3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    End If
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW43:ET62")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
    [EZ3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    End If
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW63:ET82")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
        [FB3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    End If
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW83:ET102")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
    [FD3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    End If
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set monDico = CreateObject("Scripting.Dictionary")
    Set Plage = wS.Range("CW103:ET122")
    If Application.CountA(Plage) <> 0 Then
        For Each c In Plage
            If c <> "" Then monDico(c.Value) = ""
        Next c
    [FF3].Resize(monDico.Count, 1) = Application.Transpose(monDico.keys)
    End If
    Set monDico = Nothing: Set Plage = Nothing
    '-----------------------------------------------------------------------
    Set wS = Nothing

End Sub

FAN-TAS-TI-QUE !!! Ça marche à la perfection. Je ne sais comment te remercier, tu viens de me soulager d'un gros problème. Merci, merci, merci !!!

Excellente journée à toi !

Re,

Penses à clôturer le sujet.

Cdlt