Extraction, suppression des doublons et tri

Bonjour a toutes et tous,

Sur le feuille Home, j'ai 3 listes deroulantes.

Ces listes sont alimentée via la feuille construction en y extrayant les données "Company" a l'ouverture puis en cascade "Type" et "Ref" du tableau 1 contenue dans la feuille Database.

L'extraction contenant des doublons, je procede a l'heure actuelle en copiant la colonne Company du tableau 1 dans la colonne B, a partir de B5, dans la feuille construction. Ensuite, en cascade, j'extrairais les types et ref correspondante a la company selectionné, puis la liste des ref sera affinée a la selection d'un type et une nouvelle extraction se fera basé sur le concurent et le type.

Pour le moment, je travaile a essayer de simplifier mon code sur la première extraction, celle de la liste des company. Voici mon code

Je vais copier la colonne company du tableau 1 de database et le copie en B5 puis j'applique sur la liste ainsi generée un "RemoveDuplicate" puis un tri.

option explicit

Private Sub Workbook_Open()

Dim colonne As Integer
Dim ligne As Integer
Dim ligne_bd As Integer
Dim lign_construct As Integer
Dim plage As Range

Application.ScreenUpdating = False

'Vider les colonnes de récupération alimentant les listes déroulante.
Sheets("construction").Range("Company_List_2").Value = ""
Sheets("construction").Range("Type_list_2").Value = ""
Sheets("construction").Range("Ref_list_2").Value = ""

'efface les donnée récupérées précédement
Sheets("construction").Range("Plage_extraction").Value = ""
Sheets("construction").Range("Zone_criteres").Value = ""

'Copier les données de la colonne Concurent de Database dans la colonne Concurent de Construction
Sheets("Database").Range("Tableau1[Company]").Copy
Sheets("construction").Range("B5").PasteSpecial Paste:=xlPasteValues

'Suppression des doubons et classement par ordre aphabetique
With Sheets("construction")
    Set plage = .Range("Company_List_2")
    plage.RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveWorkbook.Worksheets("construction").Sort.SortFields.clear
    ActiveWorkbook.Worksheets("construction").Sort.SortFields.Add Key:=Range("B5" _
    ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
       With ActiveWorkbook.Worksheets("construction").Sort
            .SetRange plage
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
       End With
End With

'Afficher la première valeur dans la liste list_conc
Sheets("Home").Select

Application.ScreenUpdating = True

End Sub

Après avoir fafouillé sur le net, je me dis que je pourrais peut etre remplacer cet importation, suppression des doublons et tri a l'aide d'un filtre avancé mais je n'arrive pas a le mettre en place.

Voici ma tentative.

Private Sub Workbook_Open()

Dim colonne As Integer
Dim ligne As Integer
Dim ligne_bd As Integer
Dim lign_construct As Integer
Dim plage As Range

Application.ScreenUpdating = False

'Vider les colonnes de récupération alimentant les listes déroulante.
Sheets("construction").Range("Company_List_2").Value = ""
Sheets("construction").Range("Type_list_2").Value = ""
Sheets("construction").Range("Ref_list_2").Value = ""

'efface les donnée récupérées précédement
Sheets("construction").Range("Plage_extraction").Value = ""
Sheets("construction").Range("Zone_criteres").Value = ""

'Recuperation de la liste, retrait des doublons et tri
Sheets("construction").Select
Sheets("Database").Range("Company").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "B4"), Unique:=True

Pourriez vous me dire si ce que je cherche a faire est possible? Si oui, j'ai un message d'erreur sur 'execution du filtre avancé. Sauriez vous me dire quel est l'erreur que je fais?

Voici le message d'erreur

image

Je vous remercie pour votre aide

Bastien

Bonjour,

sujet très intéressant ... et riche car on peut essayer plein de versions : filtre, recopies/suppression de doublons etc.

je pense que la plus intéressante est d'utiliser scripting.dictionnary, sans forcément le faire à l'ouverture mais simplement lors du choix des plages, voir modèle ci-joint

autre solution : faire un triptyque de TCD.

avec un TCD, la macro est simplifiée à l'extrême ! = 1 ligne

Bonjour,

Merci pourcoup pour les réponse nocturnes :-)

En effet, ces deux solution ont l'air puissante. Je ne les avais pas du tout envisager et je ne connaissait pas du tout ces possibilité d'approche ce qui fait qu'il va falloir que je les digère pour les comprendre (désolé, j'aime comprendre avant d'appliquer, ce qui parfois prends plus du temps). Je vais suremebnt avoir plein de question, notament sur la méthode scripting.dictionnary car je ne connait pas du tout cette approche. J'y ai deja jeter un oeil et le code me semble extrement obscur . mais c'est super, je vais apprendre de nouvelle choses :-)

Quelques petite question de prime abord pour m'orienter dans le choix de la bonne méthode et eviter de partir sur une fausse piste.

Est ce que les deux permettent d'afficher une valeur par defaut dans les liste déroulante? Jeveux dire par la, a l'ouverture ou bien a la remise a zero pour recommencer une nouvelle recherche, est ce qu'il est possible de faire afficher un texte du type "Select a company" "select a type" "select a reference"? Actuellement, j'ai une macro qui va ecrire du texte dans la case de la liste (cf ci-dessous). Est ce que cela restera possible avec ces méthodes? Il ya peut etre une approche moins barbaresque cela dit pour obtenir le même résultat.

Est ce que ce sont des liste déroulante évolutive. Je veux dire par la, si je rajoute une ligne dans ma base de donnée, est ce que celle-ci sera prise en compte par le systhème et disponible dans les liste déroulante? Je suppose que oui, notamment pour l'approche scripting.dictionnary mais c'est juste pour etre sur.

Encore mercie pour l'aide

Bastien

Non pour la version TCD

Oui pour la version dico ... je vais la refaire plus adaptée à ton cas.

Le programme est un peu long mais très répétitif pour être plus lisible ...

Il est surtout très réactif.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dico1 As Object

If Not Intersect(Target, Range("Choix_Company_1")) Is Nothing Then
'Choix_Company_1
    Data = Sheets("Database").Range("Tableau1[[Company]:[Reference]]").Value
    Set dico = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        dico(Data(i, 1)) = ""
    Next
    tbl = dico.keys
    QuickSort tbl
    If dico.Count > 0 Then
        With Sheets("Listes")
            If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
            .Range("A2") = "Choisir compagnie ..."
            Range("Choix_Type_1") = "Choisir type ..."
            Range("Choix_Ref_1") = "Choisir référence ..."
            On Error Resume Next
                .Range("A3").Resize(UBound(tbl), 1) = Application.Transpose(tbl)
            On Error GoTo 0
        End With
    End If

ElseIf Not Intersect(Target, Range("Choix_Type_1")) Is Nothing Then
'Choix_Type_1
    Data = Sheets("Database").Range("Tableau1[[Company]:[Reference]]").Value
    critere1 = Range("Choix_Company_1").Value
    Set dico = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        If Data(i, 1) = critere1 Then dico(Data(i, 2)) = ""
    Next
    tbl = dico.keys
    QuickSort tbl
    If dico.Count > 0 Then
        With Sheets("Listes")
            If Not .ListObjects(2).DataBodyRange Is Nothing Then .ListObjects(2).DataBodyRange.Delete
            .Range("C2") = "Choisir type ..."
            Range("Choix_Ref_1") = "Choisir référence ..."
            On Error Resume Next
                .Range("C3").Resize(UBound(tbl), 1) = Application.Transpose(tbl)
            On Error GoTo 0
        End With
    End If

ElseIf Not Intersect(Target, Range("Choix_Ref_1")) Is Nothing Then
'Choix_Ref_1
    Data = Sheets("Database").Range("Tableau1[[Company]:[Reference]]").Value
    critere1 = Range("Choix_Company_1").Value
    critere2 = Range("Choix_Type_1").Value
    Set dico = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        If Data(i, 1) = critere1 And Data(i, 2) = critere2 Then dico(Data(i, 3)) = ""
    Next
    tbl = dico.keys
    QuickSort tbl
    If dico.Count > 0 Then
        With Sheets("Listes")
            If Not .ListObjects(3).DataBodyRange Is Nothing Then .ListObjects(3).DataBodyRange.Delete
            .Range("E2") = "Choisir référence ..."
            On Error Resume Next
                .Range("E3").Resize(UBound(tbl), 1) = Application.Transpose(tbl)
            On Error GoTo 0
        End With
    End If

End If

End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Merci pour ton adaptation, c'est très gentil

Dans ton code, ce que tu as apellé Sheets("Listes") c'est la ou sont les listes déroulantes si j'ai bien compris?

Petite question, qu'est ce que "ListObjects(1)", "ListObjects(2)" et "ListObjects(3)"? Je ne vois pas a quoi ça fait référence? Ce sont les liste déroulantes?

Dans ton code, ce que tu as apellé Sheets("Listes") c'est la ou sont les listes déroulantes si j'ai bien compris?

Parfaitement, tu peux l'appeler autrement (il me semble que c'était construction pour toi)

Petite question, qu'est ce que "ListObjects(1)", "ListObjects(2)" et "ListObjects(3)"? Je ne vois pas a quoi ça fait référence? Ce sont les liste déroulantes?

Il s'agit du premier, deuxième et troisième tableau de la feuille, 1 2 et 3 remplacent les noms des tableaux, c'est plus simple !

On peut faire aussi plus condensé comme ici https://forum.excel-pratique.com/excel/extraction-suppression-des-doublons-et-tri-149050#p918902, à condition de ne pas avoir un choix pléthorique car excel limite le nombre de caractères dans ce cas.

Salut Bastien,
Salut Steelson,

Bastien, avant de faire la même chose ailleurs, ce serait une bonne habitude à prendre que de clôturer un fil et surtout d'y donner suite, en bien ou en mal...
Cher Steelson, il faudra vraiment un jour que j'aille sur ton île prendre un cours de Dico...

https://forum.excel-pratique.com/excel/liste-deroulante-et-report-de-valeur-dans-la-meme-cellule-148...


A+

Ah mais je n'avais pas fait le lien pardi !!


Dico c'est très facile ...

il faut cocher la référence microsoft forms 2.0 object library enfin je pense je ne me souviens plus très bien

ensuite déclarer l'objet

Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
    

première utilisation simple est de capter les valeurs différentes d'une liste

' mémorisation des valeurs sous forme de dictionnaire
For i = 2 To cells(rows.count,1).end(xlup).row
        dico(cells(i,1).value) = ""
Next

ne pas oublier value sinon ...

on a donc un dictionnaire appelé dico avec les termes uniques de la liste, on peut les sortir comme suit :

Dim Cle as variant
For Each Cle In dico.keys
        Debug.Print Cle
Next

mais il ne sont pas triés !! ah ben zut alors ... on va donc les transférer dans un tableau, appliquer un quicksort et les reconstruire

et voilà une utilisation simple avec chargement initial des données dans un tableau Data

Dim Data, dico As Object

    Data = Sheets("BDD").Range("A1").CurrentRegion
    Set dico = CreateObject("Scripting.Dictionary")

    ' mémorisation des valeurs sous forme de dictionnaire
    For i = 2 To UBound(Data)
        dico(Data(i, 1)) = ""
    Next

    ' transfert dans un tableau des clés pour tri
    Tbl = dico.keys
    QuickSort Tbl

    ' rechargement du dictionnaire avec clés triées et application des valeurs
    dico.RemoveAll
    For i = LBound(Tbl) To UBound(Tbl)
        dico(Tbl(i)) = 1
    Next i

    ' lecture des clés et valeurs
    For Each Cle In dico.keys
        Debug.Print Cle
    Next

avec mon quicksort magique

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

.

Enfin, si on veut en faire une liste de validation, il y a 2 options, la première et la deuxième (of course)

  • on en fait un liste dans un onglet
Tbl = dico.keys
QuickSort Tbl
Range("A2").Resize(UBound(tbl), 1) = Application.Transpose(tbl)
  • ou bien on les colle directement dans la liste de validation
        With Sheets("mafeuilledechou").Range("ici")
            .Validation.Delete
            .Validation.Add xlValidateList, Formula1:=Join(dico.keys, ",")
        End With

mais si le nombre de caractères de la liste est trop important cela met une erreur notamment lors du rechargement du fichier

Holà, Steelson, dji sô d'jà emacralé avou l'ôte gthe.
Ni vîns nin m'toirtchî m'cervè avou Dico astêure...

A+, l'ami

Bonsoir a vous deux

curulis57, je suis sincèrement désolé, ce n'est pas dans mon habitude de faire des double demande. Cema n'excuse pas mais explique, en ce moment, c'est très tendu au travail et j'ai du mal a tout suivre :-(

Bref, super, merci beaucoup, c'est beaucoup plus clair maintenant.

J'ai encore un peu de taf poiur adapter :-)

Encore merci beaucoup

Bastien

Bonjour à tous

je poursuis sur Scripting.Dictionary

il est possible bien sûr de donner une "définition" au terme entré dans le "dictionnaire", une valeur par exemple qui peut aussi être un compteur, dans c cas :

Dim Data, cptr As Object

    Data = Sheets("BDD").Range("A1").CurrentRegion
    Set cptr = CreateObject("Scripting.Dictionary")

    ' mémorisation des valeurs sous forme de dictionnaire
    For i = 2 To UBound(Data)
        cptr(Data(i, 1)) = cptr(Data(i, 1)) + 1
    Next

    ' lecture des clés et valeurs
    For Each Cle In cptr.keys
        Debug.Print Cle, cptr(Cle)
    Next

ou d'y mémoriser une information ; exemple éviter des vlookup incessants et en y stockant une adresse (https://forum.excel-pratique.com/excel/gestion-de-la-compatibilite-de-references-147842#p914172)

Dim adresse As Object
Set adresse = CreateObject("Scripting.Dictionary")

' stockage des adresses
    For each cel in plage
        adresse(cel.Value) = cel.Address
    Next

Hello

Petite question. Désolé si c’est une question “ bête” ou si la réponse est évidente

Dans ton message d’hier à 10h26, tu mettais

For i = 1 To UBound(Data)

et dans les message suivant d’explication, tu mets partout

For i = 2 To UBound(Data)

pk ce changement? Je ne comprends pas la différence que ça ferra...

En vous souhaitant à tous un bon WE

Bastien

Ce n'est pas une question bête mais très subtile

.

Dans le premier message, data était égal à

Data = Sheets("Database").Range("Tableau1[[Company]:[Reference]]").Value

c'est-à-dire le contenu du tableau Tableau1, de la colonne Company à la colonne Reference, mais uniquement les données sans les en-têtes !

.

Dans le second cas, j'ai pris un autre exemple où data est égal à

Data = Sheets("BDD").Range("A1").CurrentRegion

et cette fois-ci, l'en-tête de la colonne A est emmenée dans le tableau, donc je commence à la l'indice 2 du tableau

.

Bien vu ...

Edit ; tu viens de me mettre la puce à l'oreille, tu as raison, j'aurais aussi du commencer à 2 car avec

Data = Sheets("Database").Range("Tableau1[[Company]:[Reference]]").Value

emmène aussi l'en-tête, donc je devrais commencer à l'indice 2

.

Si j'avais écrit pour un tableau Tmotif

Data = Sheets("param").ListObjects("Tmotif").DataBodyRange.Value

Data2 = [Tmotif].Value

là oui, je pouvais commencer à 1 !

.

Merci pour ta perspicacité !

Hello

Si j'ai bien compris, il vaut mieux privilégier l'option 1 pour generer la liste car l'option 2 est limité a 255 caractères si j'ai bien compris.

Je suis désolé, j'ai essayé d'appliquer la macro que tu avais suggeré et de la customiser avec tes reco et je bloque toujours sur les Listesobjects (1), (2) et (3)

Dans l'un de tes précédents messages, tu me disais qu'ils faisaient references aux tableaux de la feuille (Nommé Home si je comprends bien dans mon fichier). Il s'agit des tableaux qui était sous les listes déroulantes comme sur la capture d'écran ci dessous?

Si tel est le cas, je vais donc leur donner un nom. est ce que je les défini comme plage de cellule ou comme tableau?

Bonne soirée et encore merci pour l'aide?

Bastien

image

Si je comprends bien, sheets("Lists") est pour toi sheets("Home"), mais dans ce cas ce n'est pas la copie d'écran ci-dessus, on st bien d'accord.

Cette feuille doit en effet comporter 3 tableaux structurés (peu importe les noms) qui comportent dans l'ordre : company, types puis références.

Mais si tu veux, je peux ré-écrire le code avec des plages nommées (et non des tableaux) si cela t'arrange !

Hello

Ha mais ok, je comprends mieux, on ne parlais pas de la même chose. Comme je t'avais envoyé un fichier excel anonymisé, je pensais que tu faisait référence a des tableau présent sur ce fichier excel et donc, j'ai essayer de retrouver des equivalences.

Ici, je t'ai mis un copie d'écran de la feuille home de mon fichier anonymisé.

Je ne me souviens plus si je t'avais expliqué comment j'envisageais de faire fonctionner mon fichier. Je te remet une copie d'écran avec les coordonées pour que tu puisses situer ce dont je parle

Sur la feuille Database, il ya la base de données.

Sur Construction, a l'heure actuelle, il y a les extractions qui permettent de construire les listes déroulantes de la feuille Home. Cette feuille est optionelle. Sur ma ^permière version du fichier, je l'utilise mais si elle n'est pas utile après simplification, ce n'est pas grave.

Sur la feuille Home, j'ai 3 listes déroulante en C8, C10 et C12 (on va regarder ces 3 la pour le moment) qui ont pour fonction de selectionner la compagnie, le type de produit et la référence. Idealement ici, il serait bien de pouvoir acceder a la liste des référence correspondant a une compagnie directement après sa selection, la selection d'un type servant juste a affiner la liste des référence. Une fois une référence selectionner, cela affiche dans le tableau en dessous (B14:B29) les data récupérer dans la base de données correspondant a la ref selectionnée.

Du, je suppose que les listobject dont tu parles sont les 3 tableaux sur la feuille construction, est ce correct?

image image

Exact, et dès que le concurrent sera sélectionné la seconde liste se mettra à jour, puis la 3ème en fonction de la sélection opéré sur le second critère.

Rechercher des sujets similaires à "extraction suppression doublons tri"