Discussion :

[lps02]

Bonsoir le forum

Encore besoin de votre aide :

J' ai réalisé un tri dans une base de données. J'extrais les ligne obtenues dans une nouvelle feuille qui me fera plusieurs calculs.
Dans la colonne A, j'ai les essences qui peuvent être les mêmes sur plusieurs lignes et changer (exemple a,b,c,c,c,a,b,g,g,g,h,t,a,a,)

de cette liste de valeur, je voudrais extraire une liste sans doublons et triée (à coller en Y3) de la feuille lotissement

J'ai essayé à partir de deux méthodes différentes mais j'obtiens avec Sub sans doublons trié 1 une liste avec doublon (toutes les essences sont là
Mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub lotissement()
 
Dim dl As Long
'selection de la feuille "BD"; determination de laderniere ligne
With Sheets("BD")
    dl = .Range("C" & .Rows.Count).End(xlUp).Row
 
 
'Selectionne la plage filtrée et le copie vers la feuille "lotissement"
    .Range("C1:R" & dl).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("lotissement").Range("A11")
End With
Call SansDoublonsTrié1
End Sub
Sub SansDoublonsTrié1()
  Dim temp()
  Set f = Sheets("lotissement")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Range(f.[a12], f.[a65000].End(xlUp)).Value
  For Each c In a
     mondico(c) = ""
  Next c
  Set dest = f.Range("Y3")
  dest.Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  dest.Resize(mondico.Count, 1).Sort Key1:=dest, Order1:=xlAscending
  Set mondico = Nothing ' libère mondico
End Sub

et avec lautre code sub listeessence, j'obtiens une liste incomplete

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Private Sub liste_essence()
    Dim Cell As Range
    Dim Tableau()
    Dim TempTab As Variant
    Dim i As Integer, j As Integer
    Dim boolVerif As Boolean
 
    ReDim Tableau(2 To 2)
    Tableau(2) = Cells(2, 16)
 
    'Boucle sur les données de la colonne P, dans la BD
    For Each Cell In Worksheets("lotissement").Range("A12:A" & _
                        Worksheets("lotissement").Range("A65536").End(xlUp).Row)
        boolVerif = False
 
        'Vérifie si le contenu de la cellule existe déjà dans le tableau
        For i = 2 To UBound(Tableau)
            'Si la donnée existe déjà dans le tableau
            If Tableau(i) = Cell Then
                boolVerif = True
                Exit For
            End If
        Next i
 
        'Si la donnée n'existe pas dans le tableau, on augmente la taille du tableau
        'et on ajoute la donnée.
        If boolVerif = False Then
            ReDim Preserve Tableau(2 To UBound(Tableau) + 1)
            Tableau(UBound(Tableau)) = Cell
        End If
 
        'Tri le contenu du tableau par ordre croissant.
        For i = 2 To UBound(Tableau)
            For j = 2 To UBound(Tableau)
                If Tableau(i) < Tableau(j) Then
                    TempTab = Tableau(i)
                    Tableau(i) = Tableau(j)
                    Tableau(j) = TempTab
                End If
            Next j
        Next i
    Next Cell
 
   'copie du tableau en Y3
 Sheets("lotissement").Range(Cells(3, 25), Cells(UBound(Tableau), 25)).Value = Application.WorksheetFunction.Transpose(Tableau)
 
End Sub

pouvez vous m'aider??

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range
 
Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("lotissement")
    For Each c In .Range("A12:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
    Next c
    .Range("Y3").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
    .Range("Y3").Resize(MonDico.Count, 1).Sort Key1:=.Range("Y3"), Order1:=xlAscending, Header:=xlNo
End With
Set MonDico = Nothing
End Sub

[lps02]

Bonsoir Mercatog

j'ai testé avec ton code mais j'ai toujours des doublons dans les essences.

Ton avis??
Ces données proviennent de la BD et je recopie les données aprés tri dans la feuille "lotissement".

J'ai teste en entrant de fausse valeurs sur les lignes (AAAA,BBB, CCC, ZZZ,ZZZ,AAA, BBB,DDD...) et dans ce cas, la procedure de tri sans doublon fonctionne.Mes données sont des especes d'arbres (CHENE HETRE...)

Ou est le Bug???
Cordialement

[mercatog]

Peut être tu as des espaces superflus. Essaies ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range
 
Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("lotissement")
    For Each c In .Range("A12:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(Trim(c.Value)) Then MonDico.Add Trim(c.Value), Trim(c.Value)
    Next c
    With .Range("Y3").Resize(MonDico.Count, 1)
        .Value = Application.Transpose(MonDico.keys)
        .Sort Key1:=Worksheets("lotissement").Range("Y3"), Order1:=xlAscending, Header:=xlNo
    End With
End With
Set MonDico = Nothing
End Sub

[lps02]

Bonsoir mercatog

Un grand merci. Pour ma gouverne, peux tu m'expliquer ce que tu as fait pour supprimer ces espaces superflus et d'où proviennent ils?

Cordialement

lps02

[mercatog]

Trim permet de supprimer les espaces au début ou en fin des mots

Tu avais peut être "Chêne liège" et "Chêne liège "
Le 2ème a un espace en fin (invisible pour l'utilisateur)