Optimisation remplissage listbox

**hamon37** · 11/03/2019, 11h48

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 :

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
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 !

**Patrice740** · 11/03/2019, 11h52

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

**mercatog** · 11/03/2019, 12h52

Bonjour

Soit utiliser une variable tableau

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
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 :

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
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

**hamon37** · 11/03/2019, 14h19

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 :

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

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 :

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

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 !

**patricktoulon** · 11/03/2019, 15h10

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 :

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

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

**hamon37** · 11/03/2019, 17h55

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

**patricktoulon** · 11/03/2019, 13h04

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 :

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
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

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 :

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

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

Optimisation remplissage listbox

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager