Optimiser code recherche sur plus de 1000 000 lignes

**nonesofar** · 22/09/2016, 11h47

Oui je vois pour la combobox, C'est assez efficace.

Mais aprés faut que je le projette sur une listbox. Je sais pas si cela est possible faut que je teste.

**Jean-Philippe André** · 22/09/2016, 12h08

Le filter a ete applique, maintenant il te faut
- copier/coller les donnees dans une zone vide
- pointer sur cette zone comme source de ta listbox

**unparia** · 22/09/2016, 12h34

Oui je vois pour la combobox, C'est assez efficace.

Mais aprés faut que je le projette sur une listbox. Je sais pas si cela est possible faut que je teste.

Je ne vois vraiment aucun intérêt (ni aucune espèce de bénéfice) à passer sur une listbox ce que l'on a sur une combobox.
Tout cela est pour moi une affaire simplissime.
1) on trie une première fois (une seule) les données de la colonne A. On ne les trie à nouveau (seul cas de nécessité) que lors d'un nouvel ajout éventuel
2) on lie la combobox à la plage des données de la colonne A (les seules lignes contenant des données)
3) on utilise la propriété MatchEntry de la combo
ET C'EST TOUT !

**nonesofar** · 22/09/2016, 13h52

Salut,

Merci de vos conseils,

suite à la demande de patrick toulon voici un ficher xlx en PJ avec peu de données.

recherche WORLD v2 developpez_forum.xlsx

En fait la combobox ne va pas afficher dans la listbox.

Je souhaite que la liste box affiche au fur à mesure les résultats.

**Jean-Philippe André** · 22/09/2016, 14h04

Pourquoi tu ne passes pas par des formulaires ou des rubans ?

Passer par des shapes, ca me fait peur pour l'utilisateur, pas toi ?

D'autre part, le probleme que tu as en nous envoyant un fichier xlsx, c'est qu'on perd tout le code que tu as pu faire jusqu'a present.

Envoie nous a minima un fichier xls =]

**nonesofar** · 22/09/2016, 14h13

Ben c'est plus simple dans un userform? Que sur une shape?

J'ai laissé mes code et fait une combobox avec la MatchEntry sur les conseils de unparia.

Juste que les résultat de la colonne A soient affichés dans la listbox, en fonction de la matchentry ça serait top.

recherche WORLD v2 dev.xlsm

**Oliv-** · 22/09/2016, 14h18

Salut,
en passant par là je me dis qu'on a quand même perdu 895013 lignes !

Envoyé par nonesofar

Ben c'est plus simple dans un userform? Que sur une shape?

J'ai laissé mes code et fait une combobox avec la MatchEntry sur les conseils de unparia.

Juste que les résultat de la colonne A soient affichés dans la listbox, en fonction de la matchentry ça serait top.

recherche WORLD v2 dev.xlsm

il faut zipper ton fichier, il y a un bug avec les xlam

**nonesofar** · 22/09/2016, 15h50

Oui j'ai enlevé des données qui avaient pas de sens pour simplifier le truc.

Voila un zip.

recherche WORLD v2 dev.7z

Je récapitule pour les nouveaux.

Je souhaite en fonction des valeur d'une combob0x afficher dans une listbox les résultats.

Au fur à mesure que l'utilisateur se rapproche d'un code existant il va rester une seule résultat.

Ex: FRMRS = Port de marseille.

Bon du coup, je me suis bien avancé.

J'ai crée un userform avec une combobox qui est relié à une liste box.

J'ai mis ce code qui fonctionne assez vite en fonction du matchentry du combobox

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
 
Private Sub ComboBox1_Change()
Dim db As Worksheet
Dim wb As Workbook
Dim sc As Worksheet
 
Set wb = ActiveWorkbook
Set db = Sheets("Dbase")
Set sc = Sheets("Results")
 
Application.ScreenUpdating = False
 
If ComboBox1 <> "" Then
 
ListBox1.clear
'
        For ligne = 2 To 104987
            If db.Cells(ligne, 2) Like "*" & ComboBox1 & "*" Then
               ListBox1.AddItem db.Cells(ligne, 1)
            End If
        Next
 
    Else
    '""
End If
End Sub

ça fait le job après je pourrais faire mieux je pense mais vais arrêter de vous embêter. Vous m'avez déjà bien aidé.

recherche WORLD - vf1 dev.7z

**patricktoulon** · 22/09/2016, 17h24

re
d'accord j'ai téléchargé ton fichier

alors il me viens une question puisque tu n'a pas de doublons pourquoi ne pas faire un find!!! directement pas besoins de boucler
la je comprends vraiment pas

d'autant plus que puisqu'il n y a pas de doublons a quoi te sert la listebox hein dis moi ????????? tu n'en aura toujours qu'un d'item dedans
j'en perds mon chinois moi
c'est plus un soucis de conception la !!

bref si tu sais un jour ce que tu veux vraiment nous le savoir hein!!!!

Invité · 22/09/2016, 23h08

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
 
Private Sub ComboBox1_Change()
     test
End Sub
Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
test
End Sub
Sub test()
With CreateObject("adodb.connection")
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
        & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
        .Open
        With .Execute("Select[Code Port /    /Nom Ville] from [Dbase$] where [Code Port] like '%" & ComboBox1 & "%'")
            Me.ListBox1.Clear
            If .EOF = False Then Me.ListBox1.List = WorksheetFunction.Transpose(.getrows)
            .Close
        End With
        .Close
    End With
End Sub

**nonesofar** · 23/09/2016, 10h52

Hello,

Merci pour vôtre aide,

Ben j'aimerais bien faire find mais je suis pas arrivé l'adapter à mon code. Je boucle parce-que, c'est le meilleur moyen d'afficher, lorsque l'utilisateur ne connait que les 2 première lettre du pays. Par exemple FR pour la France, ça va boucler et afficher l'ensemble des codes ports qui commence par FR.

Avec find ça donne le même résultat?

Merci rdurupt, mais ça fonctionne pas de manière optimale, ça lag plus qu'avec ma boucle. Comprend pas vu que ton code est bien plus pêchu.

Last update de 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
27
 
Private Sub ComboBox1_Change()
 
Dim db As Worksheet
Dim wb As Workbook
Dim sc As Worksheet
 
Set wb = ActiveWorkbook
Set db = Sheets("Dbase")
Set sc = Sheets("Results")
 
Application.ScreenUpdating = False
If ComboBox1 = "" Then
   ListBox1.clear
    Call UserForm_Initialize
 
    ElseIf ComboBox1 <> "" Then
    ListBox1.clear
    '"*************************************************************
            For ligne = 2 To 104987
                If db.Cells(ligne, 2) Like ComboBox1 & "*" Then
                   ListBox1.AddItem db.Cells(ligne, 1)
                End If
            Next
End If
 
End Sub

Invité · 23/09/2016, 11h01

Bonjour,

mais ça fonctionne pas de manière optimale, ça lag plus qu'avec ma boucle

j'ai pris en cour de route et j'ai pas tout lue et ça je ne comprend pas ce que ça veux dire!

de sur-crois, pour ton fichier fais dans l'explorateur Windows fais un click droit dessus et dans la liste chois dossier compressé ca je ne peux pas l'ouvrir!

**pijaku** · 23/09/2016, 11h12

Bonjour à tous,

Voici ma proposition.
Je suis revenu à la demande initiale, en conservant le textbox et la listbox sur la feuille, mais cela fonctionne également avec une Combobox (attention au choix de l'événement déclencheur) et une ListBox posées sur un userForm...

Cela présuppose également que les données sont dans la feuille "Feuil2", dans les colonnes A à C, sinon modifiez les constantes...
J'ai fait s'afficher les trois colonnes dans la ListBox, donc veillez à ce qu'elle soit bien Multi-Colonnes (ListBox1.ColumnCount = 3)

Attention, j'ai bien précisé qu'il s'agit d'une usine à gaz...
Cependant, le résultat, testé sur 50000 lignes s'affiche immédiatement, prévoir un petit délai pour 204281.

Dans le module de la feuille (ou de l'UserForm le cas échéant) :

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
Option Explicit
 
Const maPlage As String = "A2:C104987"
Const maColonne As Byte = 2
Const maFeuil As String = "Feuil2"
 
Private Sub TextBox1_Change()
Dim lngTest As Long, varTableau As Variant
 
    On Error Resume Next
    lngTest = UBound(Tb)
    If Err <> 0 Then Tb = Range_To_Tb(Sheets(maFeuil).Range(maPlage))
    On Error GoTo 0
 
    If TextBox1 <> "" Then
        varTableau = Filtre_Tableau(Tb, maColonne, TextBox1 & "*", "Like")
        On Error Resume Next
        lngTest = UBound(varTableau)
        If Err <> 0 Then ListBox1.Clear: Exit Sub
        On Error GoTo 0
        ListBox1.List = varTableau
    Else
        ListBox1.Clear
    End If
End Sub

Dans un module :

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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
Option Explicit
 
Public Tb As Variant
 
Public Function Range_To_Tb(Plage As Range) As Variant()
    If Plage.Cells.Count < 2 Then
       Dim tablo(1 To 1, 1 To 1)
       tablo(1, 1) = Plage.Value
       Range_To_Tb = tablo
       Erase tablo
     Else
       Range_To_Tb = Plage.Value
     End If
End Function
 
Public Function Filtre_Tableau(ByVal Tableau As Variant, _
                                             Item As Variant, _
                                             Key1 As Variant, _
                                             Optional test As String = "=") As Variant
    Dim Tbl() As Variant, i As Long, j As Long, Cpt As Long, Colonne As Long, TestColonne As Variant
 
        Select Case VarType(Item)
            Case 8: Colonne = Retourne_Colonne(Tableau, Item)
            Case 2, 3, 17: Colonne = CLng(Item)
            Case Else: GoTo Erreur_Colonne
        End Select
 
        On Error GoTo Erreur_Colonne
        TestColonne = Tableau(LBound(Tableau, 1), Colonne)
        On Error GoTo 0
        Select Case Nb_Dimensions(Tableau)
            Case 0
                MsgBox "Le tableau passé en paramètre est vide.": Exit Function
            Case 1
                MsgBox "Le tableau passé en paramètre ne comporte qu'une colonne."
                Exit Function
            Case 2
                If IsDate(Key1) Then Key1 = CDate(Key1)
                If IsNumeric(Key1) Then Key1 = CLng(Key1)
                Select Case test
                    Case "="
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) = Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case "<"
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) < Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case ">"
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) > Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case "<="
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) <= Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case ">="
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) >= Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case "<>"
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If Tableau(i, Colonne) <> Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case "Like"
                        For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                            If UCase(Tableau(i, Colonne)) Like UCase(Key1) Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
                                For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                                    Tbl(j, Cpt) = Tableau(i, j)
                                Next j
                            End If
                        Next i
                    Case Else
                        MsgBox "Le paramètre facultatif Test est erroné."
                        Exit Function
                End Select
                On Error GoTo resultat_Vide
                TestColonne = Tbl(UBound(Tbl, 1), UBound(Tbl, 2))
                On Error GoTo 0
                Filtre_Tableau = Transposition(Tbl)
                Erase Tbl
            Case Else
                MsgBox "Le tableau comporte plus de deux dimensions. La fonction n'est pas adaptée à ce cas."
        End Select
        Exit Function
Erreur_Colonne:
    MsgBox "Le paramètre Item est erroné."
    Exit Function
resultat_Vide:
    MsgBox "Le filtre renvoie un tableau vide de données."
End Function
 
Public Function Nb_Dimensions(Tableau As Variant) As Integer
    Dim D As Integer, t As Long
 
        On Error GoTo fin
        Do: D = D + 1: t = UBound(Tableau, D): Loop
fin:
    Nb_Dimensions = D - 1
End Function
 
Public Function Transposition(ByRef Tableau As Variant) As Variant
    Dim tabl, i As Long, j As Long
 
        Select Case Nb_Dimensions(Tableau)
            Case 0
                MsgBox "Le tableau passé en paramètre est vide."
            Case 1
                ReDim tabl(LBound(Tableau) To UBound(Tableau), LBound(Tableau) To 1)
                For i = LBound(Tableau) To UBound(Tableau)
                    tabl(i, LBound(Tableau)) = Tableau(i)
                Next
                Transposition = tabl
                Erase tabl
            Case 2
                ReDim tabl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To UBound(Tableau, 1))
                For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                    For j = LBound(Tableau, 2) To UBound(Tableau, 2)
                        tabl(j, i) = Tableau(i, j)
                    Next j
                Next i
                Transposition = tabl
                Erase tabl
            Case Else
                MsgBox "Le tableau comporte plus de deux dimensions"
        End Select
End Function
 
Public Function Retourne_Colonne(ByRef Tableau As Variant, _
                                         Texto As Variant) As Long
    Dim i As Long, j As Integer
 
        Retourne_Colonne = -1
        Select Case Nb_Dimensions(Tableau)
            Case 0
                MsgBox "Le tableau passé en paramètre est vide."
            Case 1
                MsgBox "Le tableau passé en paramètre n'a qu'une dimension"
            Case 2
                For i = LBound(Tableau, 1) To UBound(Tableau, 1)
                    For j = LBound(Tableau, 1) To UBound(Tableau, 1)
                        If Tableau(i, j) = Texto Then Retourne_Colonne = j: Exit Function
                    Next j
                Next i
            Case Else
                MsgBox "Le tableau comporte plus de deux dimensions."
        End Select
End Function

EDIT : J'ai ajouté une constante Colonne. Dans mon exemple, je recherche dans la colonne 2 (B) du tableau de données.

Invité · 23/09/2016, 15h22

mais ça fonctionne pas de manière optimale, ça lag plus qu'avec ma boucle. Comprend pas vu que ton code est bien plus pêchu.

moi avec ta version j'ai le sablier! la mienne c'est instantané????!

Moi

Nom : Mois.png
Affichages : 242
Taille : 110,3 Ko

Toi

Nom : toi.png
Affichages : 225
Taille : 91,3 Ko

**nonesofar** · 26/09/2016, 10h44

Hello,

Oue j'ai testé ton code de nouveau ça semble bien fonctionné merci.

En fait c'est surtout que j'ai moins le sablier en effet.

Petite question, si je veux que le résultat affiché soit en fonction des deux premières lettre. Je dois décaler le like "%" ou?

Ex : IT liste tous les codes qui commencent par IT. En fait ça permet par exemple d'obtenir tous les codes italien.

Code :

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

Execute("Select[Code Port /    /Nom Ville] from [Dbase$] where [Code Port] like '%" & Replace(ComboBox1, "*", "%") & "%'")

Encore merci rudupt

Invité · 26/09/2016, 10h58

tu tape le 2 première lettre et tu supprime ce qui est grisés dans sélection automatique! la notion like '%" & Replace(ComboBox1, "*", "%" est prise en compte dans la requête * c'est juste pour filtre sur plusieurs fragment de phrase! (F*V*8) = (FRVG8) entre autre possibilités!

Sur un requête Sql like c'est pas[*] mais [%]

mais l’exemple de l'image de mon poste précédant fonctionne!

**patricktoulon** · 26/09/2016, 11h48

bon soyons sérieux ou pas

c'est juste une question d'interprétation

robert ravi de te voir parmi nous

bon moi j'ai une autre solution si vous voulez bien la regarder de plus prêt
j'ai pris une salle mani de transformer une variable tableaux en string et vice et versa déjà la ca devrait vous titiller a l'oreille

alors
a l'activate de ton userform tu va essayer ceci:

Code :

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

1
2
3
4
5
Private Sub UserForm_Activate()
With Sheets("Dbase"): tableau = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value: End With
tabstring = Join(Application.Transpose(Application.Index(tableau, , 1)), ";")
  Debug.Print tabstring
End Sub

comme tu peux le voir c'est assez simple on créé un tableau (variable tableau)
on en recupere la colonne 1 (en plus y en a qu'une c'est facile)dans un array a 1 dimension et horizontale
ensuite on join les items avec comme séparateur (jai choisi le ";")
on obtiens donc a partir de ceci:

1

2

3

4

etc.....

5et.....
on obtien ceci:

1

2

3

4

et.....

tu vois c'est pas compliqué
maintenant dans le change de ta combobox1 tu split le te texte obtenue par la valeur de celle ci et tu gardera la partie 2 (1 en terme d'item)
maintenant que tu a ta liste en string a partir de l'indice de la combo tu la re split par les ";" et tu fout le split dans la listebox1

point barre !!!!
c'est instantané!!!!! avec les outils les plus basiques de VBA

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
Dim tabstring
Private Type Position
Left As Single
Top As Single
End Type
dim tabstring as string
Private Sub UserForm_Activate()
With Sheets("Dbase"): tableau = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value: End With
tabstring = Join(Application.Transpose(Application.Index(tableau, , 1)), ";")
  Debug.Print tabstring' juste pour regarder le résultat dans le debug 
End Sub
 
Private Sub ComboBox1_Change()
  ListBox1.Clear
  If UBound(Split(tabstring, "Code Port : " & ComboBox1)) > 0 And ComboBox1.Value <> "" Then
  code = "Code Port : " & ComboBox1 & Split(tabstring, ComboBox1)(1)
   ListBox1.List = Split(code, ";")
End If
End Sub
 
Private Sub UserForm_Layout()
Static Pos As Position
Dim Mvd As Boolean
'If the form is just being initialized, store the position
If Pos.Left = 0 Or Pos.Top = 0 Then
Pos.Left = Me.Left
Pos.Top = Me.Top
Exit Sub
End If
'Check to see if the form has been moved
Mvd = False
If Me.Left <> Pos.Left Then
Me.Left = Pos.Left
Mvd = True
End If
If Me.Top <> Pos.Top Then
Me.Top = Pos.Top
Mvd = True
End If
If Mvd Then
MsgBox "Please don't move me !", vbCritical
End If
End Sub

**nonesofar** · 27/09/2016, 13h51

Hello Patrick Toulon,

Merci à toi

Oui je pense qu'il y à une coquille ou je sais pas mais j'ai une erreur.

Code :

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

1
2
3
4
5
6
7
 
Dim tabstring
Private Type Position
Left As Single
Top As Single
End Type
dim tabstring as string 'nom ambigue

**patricktoulon** · 27/09/2016, 14h24

oui !! enlève celui d'en haut

Optimiser code recherche sur plus de 1000 000 lignes [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager