Optimisation remplissage listbox

Version imprimable

Bonjour,

Dans le cadre d'un projet perso, je voudrais créer une listBox avec les valeurs de la colonne A de ma feuille. Cette feuille contient plus de 250 000 lignes.

Mon code permet de lire tous les champs, de supprimer les doublons et aussi de les mettre en ordre Alphanumérique !

Mais comme vous pouvez imaginer, le code prend énormément de temps... je recherche donc un peu d'aide pour gagner en rapidité ;)

J'ai essayé les codes suivant sans vraiment de changement...

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Mon code est le suivant :
Code:

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 Sub UserForm_Initialize() Dim DernLigne As Long Dim I As Integer Dim temp Dim Ok As Boolean 'Comptage du nombre de lignes DernLigne = Range("A1048576").End(xlUp).Row 'Remplissage de la listbox ListBox1.Clear ListBox1.ColumnCount = 2 Set f = Sheets("FEC 2018") Set mondico = CreateObject("Scripting.Dictionary") For c = 2 To DernLigne Cells(c, 1).Value = UCase(Left(Cells(c, 1).Value, 1)) & Right(Cells(c, 1).Value, Len(Cells(c, 1).Value) - 1) If Not mondico.Exists(Cells(c, 1).Value) Then mondico.Add Cells(c, 1).Value, Cells(c, 1).Value Next c Me.ListBox1.List = mondico.items ListBox1.AddItem 'Tri par Ordre Alphanumérique With Me.ListBox1 Do Ok = True For I = 0 To .ListCount - 2 If .List(I) > .List(I + 1) Then temp = .List(I) .List(I) = .List(I + 1) .List(I + 1) = temp Ok = False End If Next I Loop Until Ok = True End With 'Remplissage de la combobox ComboBox1.AddItem "Achats" ComboBox1.AddItem "Banque" ComboBox1.AddItem "Opérations Diverses" ComboBox1.AddItem "Ventes" End Sub
Un énorme merci à tous ceux qui voudront bien m'apporter de l'aide :)

Bonne journée

PS : Je ne programme que depuis 1 an, je me considère donc comme débutant !

11/03/2019, 10h52
Patrice740

Bonjour,

Merci de modifier ton post avec les balises CODE :
https://www.developpez.net/forums/d3...-balises-code/
http://club.developpez.com/aidenouve...es/Balises.gif

Bonjour

Soit utiliser une variable tableau

Code:

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub UserForm_Initialize()
Dim DernLigne As Long, i As Long
Dim MonDico As Object
Dim Tb
 
ListBox1.Clear
ListBox1.ColumnCount = 2
 
With Sheets("FEC 2018")
    DernLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:A" & DernLigne)
End With
 
Set MonDico = CreateObject("Scripting.Dictionary")
For i = 1 To DernLigne - 1
    Tb(i, 1) = UCase(Left(Tb(i, 1), 1)) & Mid(Tb(i, 1), 2)
    If Not MonDico.Exists(Tb(i, 1)) Then MonDico.Add Tb(i, 1), Tb(i, 1)
Next i
Tb = MonDico.items
QuickSort Tb, LBound(Tb), UBound(Tb)
ListBox1.List = Tb
End Sub
 
 
Sub QuickSort(List, ByVal lngMin As Long, ByVal lngMax As Long)
Dim strMidValue As String
Dim lngHi As Long
Dim lngLo As Long
Dim lngIndex As Long
 
' S'il y a 0 ou 1 élément dans la liste,
' la sous-liste est déjà triée
If lngMin >= lngMax Then Exit Sub
 
' Valeur de partionnement
lngIndex = Int((lngMax - lngMin + 1) * Rnd + lngMin)
strMidValue = List(lngIndex)
 
' Echanger les valeurs
List(lngIndex) = List(lngMin)
 
lngLo = lngMin
lngHi = lngMax
Do
    ' Chercher, à partir de lngHi, une valeur < strMidValue
    Do While List(lngHi) >= strMidValue
        lngHi = lngHi - 1
        If lngHi <= lngLo Then Exit Do
    Loop
    If lngHi <= lngLo Then
        List(lngLo) = strMidValue
        Exit Do
    End If
 
    ' Echanger les valeurs lngLo et lngHi
    List(lngLo) = List(lngHi)
 
    ' Chercher à partir de lngLo une valeur >= strMidValue
    lngLo = lngLo + 1
    Do While List(lngLo) < strMidValue
        lngLo = lngLo + 1
        If lngLo >= lngHi Then Exit Do
    Loop
    If lngLo >= lngHi Then
        lngLo = lngHi
        List(lngHi) = strMidValue
        Exit Do
    End If
 
    ' Echanger les valeurs lngLo et lngHi
    List(lngHi) = List(lngLo)
Loop
 
' Trier les 2 sous-listes
QuickSort List, lngMin, lngLo - 1
QuickSort List, lngLo + 1, lngMax
End Sub

Soit utiliser une feuille tampon

Code:

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
Private Sub UserForm_Initialize()
Dim DernLigne As Long
Dim Ws As Worksheet
 
Application.ScreenUpdating = False
ListBox1.Clear
ListBox1.ColumnCount = 2
 
Set Ws = ThisWorkbook.Worksheets.Add
With Sheets("FEC 2018")
    DernLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A2:A" & DernLigne).Copy Ws.Range("A1")
End With
 
With Ws
    .Range("A1:A" & DernLigne - 1).RemoveDuplicates Columns:=1, Header:=xlNo
    DernLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    With .Range("B1:B" & DernLigne)
        .Formula = "=UPPER(LEFT(A1,1))&MID(A1,2,200)"
        .Value = .Value
    End With
    .Range("B1:B" & DernLigne).Sort key1:=.Range("B1")
    ListBox1.List = .Range("B1:B" & DernLigne).Value
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = False
End With
Set Ws = Nothing
End Sub

bonjour
ben c'est normal que ca rame un peu tu change la valeur de chaque cellule dans ta boucle a chaque tour pour le mettre en nom propre
deja la methode c'est boff pour la majuscule

alors etant donné que tu travaille avec un dico on peut pas globaliser le remplissage on est bien obligé de boucler
cela dit tu pourrais le faire dans une variable tableau ca accélèrerait le proccessus
et pas mettre la majuscule a chaque tour MAIS !!! a la fin si c'est vraiment necessaire

donc

Code:

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
Private Sub UserForm_Activate()
    Dim tableau, C&, mondico, I, II
    Set f = Sheets("FEC 2018")
    Set mondico = CreateObject("Scripting.Dictionary")
    With Me.ListBox1
        .Clear
        .ColumnCount = 2
        tableau = f.Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value    ' on recupere la plage occupé en colonne "A"
        'Remplissage de la listbox
        For C = LBound(tableau) To UBound(tableau)
            tableau(C, 1) = StrConv(Cells(C, 1).Value, vbProperCase)    ' on converti en nom propre la valeur
            If Not mondico.Exists(tableau(C, 1)) Then    ' si il nexiste pas
                mondico.Add tableau(C, 1), tableau(C, 1)    'on le met dans le dico
                .AddItem tableau(C, 1)    ' ET !!! on l'ajoute a la listbox
            End If
        Next C
        ' ListBox1.AddItem ' a quoi sert celui la ?????.???????' je supprime !!!!!!!!!!!!!!!!
        'tri alphabetique
        For I = 0 To .ListCount - 2
            For II = I + 1 To .ListCount - 1
                If .List(II) < .List(I) Then temp = .List(I): .List(I) = .List(II): .List(II) = temp
            Next
        Next
        ' et c'est ICI !!!!  que si tu veux vraiment corriger la majuscule dans la colonne
        'debloque cette ligne ci dessous ca le fera tout d'un coup sinon laisse la bloquée
        'Sheets("FEC 2018").Cells(2, 1).Resize(UBound(tableau), 1) = tableau
    End With
    'Remplissage de la combobox pour une petite liste on peut se servir d'un array pour le ".List"
    ComboBox1.List = Array("Achats", "Banque", "Opérations Diverses", "Ventes")
End Sub

A NOTER QUE J'AURAIS TRES BIEN PU FAIRE LE TRI DANS LA VARIABLE TABLEAU AVANT DE LA METTRE DANS LA LISTBOX

@mercatog on c'est croisés;):coucou:
edit:
pour le tri tu pourrais mettres ces lignes cidessous dans le if du remplissage le nombres de tour de boucles seraient progressifs en fonction de la liste

Code:

1
2
3
4
5
For I = 0 To .ListCount - 2
                    For II = I + 1 To .ListCount - 1
                        If .List(II) < .List(I) Then temp = .List(I): .List(I) = .List(II): .List(II) = temp
                    Next
                Next

Tout d'abord; merci énormément à vous deux !!!!!

Désormais, mon code s’exécute en quelques secondes :)

En plus les explications m'ont vraiment aidé à comprendre votre logique de programmation !

Dans un deuxième temps, j'ai un autre userform toujours dans la même feuille avec lequel je veux faire apparaître les valeurs sans doublons (j'ai utilisé le même code). De plus je veux indiquer les occurrences pour chaque valeur.

le code pour les occurrences que j'utilise actuellement (encore une fois très long à traiter..):

Je pense que l'on peut l'améliorer mais je ne vois pas trop comment.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 For Z = 0 To ListBox3.ListCount - 1 For t = 2 To DernLigne If ListBox3.List(Z) = Cells(t, vcolonne).Value Then compteur = compteur + 1 End If Next t ListBox3.AddItem ListBox3.List(Z, 1) = compteur compteur = 0 Next Z
Et deuxièeme question :

je voudrais remplir la listbox avec les valeurs d'une colonne qui n'est pas toujours au même emplacement et je voudrais quelle se remplisse sans vide (ce n'est pas le cas en ce moment..)!
Mais cette ligne me pose problème pour intégrer ma variable... "f.Range("H2", Cells(Rows.Count, 8).End(xlUp)).Value"

Mon code adpaté du votre :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Colonne = InputBox("Quelle est la colonne où se situe les données ?") vcolonne = Asc(UCase(Colonne)) - 64 tableau = f.Range("H2", Cells(Rows.Count, 8).End(xlUp)).Value 'Remplissage de la listbox For C = LBound(tableau) + 1 To UBound(tableau) 'tableau(C, 1) = StrConv(Cells(C, 1).Value, vbProperCase) ' on converti en nom propre la valeur If Not mondico.Exists(tableau(C, 1)) Then ' si il nexiste pas mondico.Add tableau(C, 1), tableau(C, 1) 'on le met dans le dico .AddItem tableau(C, 1) ' ET !!! on l'ajoute a la listbox End If Next C
j'espère ne pas abuser de votre gentillesse ;)

Merci encore à tous ceux qui viendront m'aider !

11/03/2019, 14h10
patricktoulon

re

Citation:

je voudrais remplir la listbox avec les valeurs d'une colonne qui n'est pas toujours au même emplacement et je voudrais quelle se remplisse sans vide (ce n'est pas le cas en ce moment..)!
Mais cette ligne me pose problème pour intégrer ma variable... "f.Range("H2", Cells(Rows.Count, 8).End(xlUp)).Value"

reponse

Code:

tableau = f.Range(f.Cells(2, vcolonne), f.Cells(Rows.Count, vcolonne).End(xlUp)).Value

;)
11/03/2019, 16h55
hamon37

Encore merci pour la ligne de code !
Ça fonctionne super :)

Dernière question avant de clôturer le sujet, existe-t-il un code pour calculer l’occurrence des valeurs dans une colonne ?
Si non, est-on obligé de passer par une boucle et un compteur ?

Merci encore

Bonne fin de journée ;)
11/03/2019, 17h31
mercatog

La fonction Nb.si

Citation:

Envoyé par hamon37

Encore merci pour la ligne de code !
Ça fonctionne super :)

Dernière question avant de clôturer le sujet, existe-t-il un code pour calculer l’occurrence des valeurs dans une colonne ?
Si non, est-on obligé de passer par une boucle et un compteur ?

Merci encore

Bonne fin de journée ;)

en vba tu a plusieurs chemin

avec
countif
test match comparé a la ligne dans la boucle
collection
dictionnaire
systemcollection
etc....

par exemple je me suis amusé a remplir une listbox sans doublons et sans dictionnaire ou collection et sans variable tableau avec seulement un test match
je sais ce que ca vaut sur une longue plage (a tester)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Private Sub UserForm_Activate() Dim f As Worksheet, moins&, I&, II&, cel As Range Set f = Sheets("FEC 2018") Set Rng = f.Range("A2", Cells(Rows.Count, 1).End(xlUp)) ' on recupere la plage occupé en colonne "A" moins = Rng.Row - 1 For Each cel In Rng.Cells If cel.Row - moins = Application.Match(cel.Text, Rng, 0) Then ListBox1.AddItem StrConv(cel.Text, vbProperCase) Next 'tri alphabetique With ListBox1 For I = 0 To .ListCount - 2 For II = I + 1 To .ListCount - 1 If .List(II) < .List(I) Then temp = .List(I): .List(I) = .List(II): .List(II) = temp Next Next End With End Sub

Bonjour,

Merci énormément à vous deux pour toute l'aide que vous m'avez apporté ! J'ai vraiment beaucoup appris sur les listbox c'est top !!!!!

Pour ceux que ça peut intéresser, j'ai réussi à remplir une listbox avec les valeurs de la colonne en variable (Inputbox) et leurs occurrences respectives.

Voici le code utilisé :

Code:

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
Sub UserForm_Initialize()
Dim dl As Long    'déclare la variable dl (Dernière Ligne)
Dim pl As Range    'déclare la variable pl (PLage)
Dim dico As Object    'déclare la variable dico (DICtiOnnaire)
Dim cel As Range, Cel2    'déclare la variable cel (CELLule)
Dim temp As Variant    'déclare la variable temp (tableau TEMPoraire)
 
DernLigne = Worksheets("FEC 2018").Range("A1048576").End(xlUp).Row
Sheets("FEC 2018").Activate
colonne = InputBox("Quelle est la colonne où se situe les comptables ?")
vcolonne = Asc(UCase(colonne)) - 64
 
Set dico = CreateObject("Scripting.Dictionary")    'définit le dictionnaire dico
    With Sheets("FEC 2018")    'prend en compte l'onglet "Feuil1"
        dl = .Cells(Application.Rows.Count, vcolonne).End(xlUp).Row    'définit la dernière ligne dl de la colonne B
        Set pl = Range(Cells(2, vcolonne), Cells(DernLigne, vcolonne)) '.Range("Colonne&2:Colonne" & dl)    'définit la plage pl
        For Each cel In pl    'boucle sur toutes les cellules cel de la plage pl
            Cel2 = cel.Value
            dico(Cel2) = dico(Cel2) + 1  'alimente le dictionnaire
        Next cel    'prochaine cellule de la boucle
        temp = dico.keys
        Call Tri(temp, LBound(temp), UBound(temp))
        [D1] = "Code": [E1] = "Nbr"
 
        For x = 1 To UBound(temp)
            ListBox3.AddItem
             ListBox3.List(x - 1, 0) = temp(x)
             ListBox3.List(x - 1, 1) = dico.Item(temp(x))
        Next x
    End With
End Sub

Le code tri que j'ai récupéré sur un site dont je vous ai mis le lien :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Tri(a As Variant, gauc As Integer, droi As Integer)    'tiré du site de Jacques BOISGONTIER http://boisgontierjacques.free.fr/
    Dim ref As Variant
    Dim g As Integer, d As Integer
    Dim tmp As Variant
 
    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
            tmp = a(g): a(g) = a(d): a(d) = tmp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi)
    If gauc < d Then Call Tri(a, gauc, d)
End Sub

je vais clôturer le sujet car désormais mon fichier fonctionne nickel !

Merci encore et bonne journée à vous ;)

13/03/2019, 09h20
patricktoulon

re

Bonjour
si je comprend bien tes valeurs sont des numeriques ?
et la colonne 2 de la listbox c'est la valeur colonne 1 +1?
13/03/2019, 09h31
hamon37

Non, la listbox permet d'afficher :

En colonne 1 : Tous les comptables présent dans la colonne H sans doublon et trié par ordre alphanumérique
En colonne 2 : Le nombre de fois ou le comptable de la colonne 1 apparaît dans la colonne H

Je ne suis pas sûr que ma solution soit optimal mais elle fonctionne pas trop mal ;)
13/03/2019, 09h56
patricktoulon

re

re
verifie bien que le nombre d'occurences se deplace bien avec les noms javec cette methode de tri ,je suis perplexe

sauf erreur de ma part il me semble qu'elle tri 1 colonne et que la bascule item/temp se fait sur cette colonne
je dis bien sauf erreur de ma part ;)

1 pièce(s) jointe(s)

Bonjour,

Tri Array() 2D:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub TriTableau2D()
 Dim a()
 a = [A2:D6].Value      ' Tableau 2D
 Tri a(), 1, LBound(a, 1), UBound(a, 1)
 [F2].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
End Sub
 
Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
   ref = a((gauc + droi) \ 2, ColTri)
   g = gauc: d = droi
   Do
      Do While a(g, ColTri) < ref: g = g + 1: Loop
      Do While ref < a(d, ColTri): d = d - 1: Loop
        If g <= d Then
           For k = LBound(a, 2) To UBound(a, 2)
             temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
           Next k
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call Tri(a, ColTri, g, droi)
    If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Boisgontier