accélération d'un code VBA

davidan · 3 Août 2005

bonjour à tous!!!
j'ai élaboré un code me permettant de remplacer le filtre automatique à l'aide d'une userform.
ce filtrage se fait selon 7 critère.
ma userform marche très bien mais comme mon tableau fait (pour l'instant) 6000 lignes le filtrage me prend 50sec:c'est beaucoup trop long!! et le temps se ralonge avec le nombre de ligne.
je vous fait par de mon code ci joint.
là j'avoue que je peine
j'ai bien essayé de déclarer mes variables, de stopper le scintillement de l'écran...) mais le gain de temps et négligeable.
même l'apparition de la userform prend 15 sec ( car j'élimine les doublons).
si quelqu'un a une proposition pour rendre mon code plus fonctionnel,je le remercie par avance;
et merci à tous car c'est grace à vous que j'ai établis cette userform.

voici mon code:
Private Sub bouton_annulation_Click()
UserForm1.Hide
Unload UserForm1
End Sub

Private Sub UserForm_Initialize()
Dim Dbase1 As New Collection
Dim Item
Dim cell As Range
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('G12:G' & .Range('G65536').End(xlUp).Row)
If cell <> '' Then
Dbase1.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase1
ComboBox1.AddItem Item
Next Item
Dim Dbase2 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('K12:K' & .Range('K65536').End(xlUp).Row)
If cell <> '' Then
Dbase2.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase2
ComboBox2.AddItem Item
Next Item
Dim Dbase3 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('C12:C' & .Range('C65536').End(xlUp).Row)
If cell <> '' Then
Dbase3.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase3
ComboBox3.AddItem Item
Next Item
Dim Dbase4 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('D12

' & .Range('D65536').End(xlUp).Row)
If cell <> '' Then
Dbase4.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase4
ComboBox4.AddItem Item
Next Item
Dim Dbase5 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('L12:L' & .Range('L65536').End(xlUp).Row)
If cell <> '' Then
Dbase5.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase5
ComboBox5.AddItem Item
Next Item
Dim Dbase6 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('M12:M' & .Range('M65536').End(xlUp).Row)
If cell <> '' Then
Dbase6.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase6
ComboBox6.AddItem Item
Next Item
Dim Dbase7 As New Collection
With Worksheets('feuil1')
On Error Resume Next
For Each cell In Range('N12:N' & .Range('N65536').End(xlUp).Row)
If cell <> '' Then
Dbase7.Add cell.Text, cell.Text
End If
Next cell
End With
For Each Item In Dbase7
ComboBox7.AddItem Item
Next Item
End Sub

Private Sub bouton_OK_Click()
On Error Resume Next
Application.ScreenUpdating = False
If ComboBox1.Value = 'tous' Then
Range('G12').AutoFilter field:=7
Else
Range('G12').AutoFilter field:=7, Criteria1:=ComboBox1.Value
End If
If ComboBox2.Value = 'tous' Then
Range('K12').AutoFilter field:=11
Else
Range('K12').AutoFilter field:=11, Criteria1:=ComboBox2.Value
End If
If ComboBox3.Value = 'tous' Then
Range('C12').AutoFilter field:=3
Else
Range('C12').AutoFilter field:=3, Criteria1:=ComboBox3.Value
End If
If ComboBox4.Value = 'tous' Then
Range('D12').AutoFilter field:=4
Else
Range('D12').AutoFilter field:=4, Criteria1:=ComboBox4.Value
End If
If ComboBox5.Value = 'tous' Then
Selection.AutoFilter field:=12
Else
Range('feuil1!L12').AutoFilter field:=12
Range('feuil1!L12:L65536').NumberFormat = '0'
Range('feuil2!A1').Value = ComboBox5.Value
Range('feuil2!A1') = CDate(ComboBox5.Value)
Range('feuil2!A1').NumberFormat = 'dd/mm/yy'
Range('feuil2!A1').Font.ColorIndex = 35
Range('L12').AutoFilter field:=12, Criteria1:=Range('feuil2!A1')
Range('L12') = ''
End If

If ComboBox5.Value = 'non émise' Then
Range('feuil1!L12').AutoFilter field:=12, Criteria1:=Empty
End If

If ComboBox6.Value = 'tous' Then
Range('M12').AutoFilter field:=13
Else
Range('feuil1!M12').AutoFilter field:=13
Range('feuil1!M12:M65536').NumberFormat = '0'
Range('feuil2!B1').Value = ComboBox6.Value
Range('feuil2!B1') = CDate(ComboBox6.Value)
Range('feuil2!B1').NumberFormat = 'dd/mm/yy'
Range('feuil2!B1').Font.ColorIndex = 35
Range('M12').AutoFilter field:=13, Criteria1:=Range('feuil2!B1')
Range('M12') = ''
End If

If ComboBox6.Value = 'non levée' Then
Range('feuil1!M12').AutoFilter field:=13, Criteria1:=Empty
End If

If ComboBox7.Value = 'tous' Then
Range('N12').AutoFilter field:=14
Else
Range('feuil1!N12').AutoFilter field:=14
Range('feuil1!N12:N65536').NumberFormat = '0'
Range('feuil2!C1').Value = ComboBox7.Value
Range('feuil2!C1') = CDate(ComboBox7.Value)
Range('feuil2!C1').NumberFormat = 'dd/mm/yy'
Range('feuil2!C1').Font.ColorIndex = 35
Range('M12').AutoFilter field:=14, Criteria1:=Range('feuil2!C1')
Range('M12') = ''
End If

If ComboBox7.Value = 'non contrôlée' Then
Range('feuil1!L14').AutoFilter field:=14, Criteria1:=Empty
End If

Range('feuil1!L12:L65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!M12:M65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!N12:N65536').NumberFormat = 'dd/mm/yy'

Range('A12').Select
ActiveCell.FormulaR1C1 = 'tous'
Selection.AutoFill Destination:=Range('A12:Q12'), Type:=xlFillDefault
Unload UserForm1
End Sub

_Thierry · 3 Août 2005

Bonjour Davidan, le Forum

Non, ce n'est pas bon du tout pour l'initialisation du UserForm, pour le reste, je n'ai pas regardé.

Tu es en train de scanner Sept Fois ta feuille sur 6000 lignes, normal que ça prenne du temps...

Voilà déjà qui devrait booster ton Userform

Option Explicit

Private Sub UserForm_Initialize()
Dim TabData As Variant
Dim Dbase1 As New Collection
Dim Dbase2 As New Collection
Dim Dbase3 As New Collection
Dim i As Long
Dim Item

    With Worksheets('Feuil1')
        TabData = Range('C12:N' & .Range('C65536').End(xlUp).Row)
    End With

    For i = 1 To UBound(TabData, 1)
            If TabData(i, 5) <> '' Then '(5 = Col G)
                On Error Resume Next
                Dbase1.Add TabData(i, 5), CStr(TabData(i, 5))
                On Error GoTo 0
            End If
            If TabData(i, 9) <> '' Then '(9 = Col K)
                On Error Resume Next
                Dbase2.Add TabData(i, 9), CStr(TabData(i, 9))
                On Error GoTo 0
            End If
            If TabData(i, 1) <> '' Then '(1 = Col C)
                On Error Resume Next
                Dbase3.Add TabData(i, 1), CStr(TabData(i, 1))
                On Error GoTo 0
            End If
    Next i

    For Each Item In Dbase1
        ComboBox1.AddItem Item
    Next Item
   
    For Each Item In Dbase2
        ComboBox2.AddItem Item
    Next Item
   
    For Each Item In Dbase3
        ComboBox3.AddItem Item
    Next Item

End Sub

Voilà tout doit se faire en un seul passage... Ici en prime je mets tout dans un tableau Variant en mémoire, comme çà on ne lit plus la feuille...

Je n'ai fait que la trois premières Combo, à toi de faire la suite dans la Logique que TabData est constitué TabData(Ligne, Colonne) :
Et pour les Colonne en Chiffre :
1 => C
2 => D
3 => E
4 => F
5 => G
6 => H
7 => I
8 => J
9 => K
10 => L
11 => M
12 => N

Bonne Soirée
[ol]@+Thierry[/ol]

Hervé · 3 Août 2005

Bonjour davidan

Une proposition pour initialise de l'userform, je sais pas si ceci va accélérer le traitement, a voir :

Private Sub UserForm_Initialize()
Dim tablo As Variant
Dim data As Collection
Dim colonne As Variant
Dim x As Byte
Dim i As Integer

x = 1
tablo = Range('c12:n' & Range('c65536').End(xlUp).Row)

For Each colonne In Array('1', '2', '5', '9', '10', '11', '12')
    Set data = New Collection
    For i = 1 To UBound(tablo)
        On Error Resume Next
        data.Add CStr(tablo(i, colonne)), CStr(tablo(i, colonne))
        On Error GoTo 0
    Next i
   
    For i = 1 To data.Count
        Controls('combobox' & x).AddItem data.Item(i)
    Next i
    x = x + 1
    Set data = Nothing
Next colonne
End Sub

A faire a suivre

PS : pas mal Thierry pour le array

salut

Hervé · 3 Août 2005

re davidan, salut thierry

oups, je t'avais pas vu thierry.

Davidan, y'a pas photo choisi la méthode de thierry, bien plus rapide.

Salut

_Thierry · 3 Août 2005

Bonjour Hervé, re Davidan

Y a pas d'mal Hervé

Par contre c'est le concepte de ton algo... qui me chiffonne...

Car en fait tu mets les Mêmes Data (Collection) dans toutes les Combo sur ce coup là... (Non ?)

Niveau rapidité, ce doit être idem, le principal étant de passer en un passage sur un Tableau en Ram.

Bonne Soirée
[ol]@+Thierry[/ol]

PS oui les Array c'est sympa pour les trucs 'Bordelicussassynchronique' !!! LOL

EDITION 1 !!!

Autant pour moi, j'avais pas fait gaffe que tu étais dans la Boucle Each Colonne pour une New Collection... Donc OK ! Sorry

EDITION 2 !!!

Mais par contre, oui tu économises des lignes de codes mais tu scannes à nouveau le Tableau 7 fois, donc sans essayer, je te crois sur parole, ça doit aller mois vite...

Message édité par: _Thierry, à: 03/08/2005 17:59

Message édité par: _Thierry, à: 03/08/2005 18:08

Hervé · 3 Août 2005

re davidan, thierry

oui je vide bien ma collection a chaque fois mais je reste quand meme sur 7 boucles, donc vraiment pas top.

Par contre tu as asphyxié davidan, avec ton code turbo

on le voit plus.

Bon concert (je suis fou de jalousie

)

salut

davidan · 4 Août 2005

merci thierry et merci à vous tous
mais croit tu qu'il est possible d'utiliser une methode similaire pour le filtrage.
comme t'as du le constater je suis pas un expère en VBA...
j'essaye ta méthode.

_Thierry · 4 Août 2005

Bonjour Davidan, re Hervé, le Forum

Une méthode similaire pour le Filtrage... Oui bien sûr, mais la plus grosse difficulité résidera dans le fait que je ne vois pas matérièllement les données à trier.
(A travers le Code c'est beaucoup trop abstrait)

Par conséquent, tu risques d'avoir à rédiger chacun de tes filtres en VBA, et donc sur des Tableaux qui eux mêmes génèreront d'autres tableaus indexés dynamiquement. Je ne te cacherai pas que c'est du travail, et ce sera assez hardu pour un débutant.

Par ailleurs si tu fais agir les AutoFilter d'Excel en étant Pilotés par, ils devraient aller tout de même très vite.

A mon avis ce qui doit ralentir ce doit être cette condition Else avec cet espèce de Bazard que je ne comprends même pas moi-même (!)

Else
Range('feuil1!L12').AutoFilter field:=12
Range('feuil1!L12:L65536').NumberFormat = '0'
Range('feuil2!A1').Value = ComboBox5.Value
Range('feuil2!A1') = CDate(ComboBox5.Value)
Range('feuil2!A1').NumberFormat = 'dd/mm/yy'
Range('feuil2!A1').Font.ColorIndex = 35
Range('L12').AutoFilter field:=12, Criteria1:=Range('feuil2!A1')
Range('L12') =

Et puis ce formattage aussi :
Range('feuil1!L12:L65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!M12:M65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!N12:N65536').NumberFormat = 'dd/mm/yy'

J'ai un peu l'impression que tu mélanges trop de choses dans cette macro qui devrait ne servir qu'à filtrer sur certains champs et pas pour appliquer des Formats...

Sinon n'oublies pas que pour réinitialiser un AutoFilter il y a la méthode Worksheets('Sheet1').ShowAllData...
Car toutes ces lignes :
Range('G12').AutoFilter field:=7 (etc)
Doivent aussi ralentir...

Voilà tout ce que je peux faire pour toi pour l'instant.

Bonne Fin de Journée
[ol]@+Thierry[/ol]

H - 28 = U 2

davidan · 4 Août 2005

salut thierry
en fait cette bizarrerie me sert à filtrer des dates: j'ai mis tres longtemps à résoudre ce problème et c'est le seul moyen que j'ai trouvé qui marchait
en fait je m'occupe du levé des réserves d'un chantier de batiment
ainsi mes champs filtré sont les sous-traitants concernés,les étages,les zones et les dates de levée par moi , l'architecte et le client(je bosse pour l'entrepreneur
demain j'essayerai de t'envoyer tout mon programme par fichier joint mais normalement c'est un peu confidentielle alors ne diffuse pas ça à mes sous traitants(je plaisante)
merci pour ton aide en tout cas.

_Thierry · 4 Août 2005

Re Bonsoir Davidan

Ouh la la tout ça pour ça !!!

Pour des Dates dans un AutoFilter orientes toi plutôt vers ceci que cette usine à gaz

Mais c'est normal que tu es un peu galéré car les dates sont toujours un Souci à gérer à travers VBA... Voici une Proposition avec gestion d'erreur :

Sub AutoFilterWithDate()
Dim WS As Worksheet
Dim x As Date
Dim y As Date

Set WS = Sheets('Planning')

On Error GoTo Out
x = CDate(InputBox('date Début ex:01/01/2005', 'Date From: ', '01/05/2005'))
y = CDate(InputBox('date Fin ex:22/01/2005', 'Date TO: ', '05/05/2005'))

WS.Range('A1').AutoFilter Field:=2, Criteria1:='>=' & Format(x, 'mm/dd/yy'), Operator:=xlAnd, Criteria2:='<=' & Format(y, 'mm/dd/yy')

Exit Sub

Out:
    If Err = 13 Then
        MsgBox 'Veuiller saisir une Date Valide', vbCritical, 'Alert !!!'
        If WS.FilterMode = True Then WS.ShowAllData
    Else
        MsgBox 'Erreur non Gérée ' & Err.num & ' ' & Err.Description
    End If
End Sub

Evidemment les dates peuvent provenir de controls TextBox de UserForm ou d'un ActiveX Calendar...

Bonne Soirée
[ol]@+Thierry[/ol]

H - 25 = U 2

_Thierry · 4 Août 2005

Davidan, petit ajout... Qaund tu dis 'demain j'essayerai de t'envoyer...'

Demain je ne serai pas devant un écran, enfin si un écran de 60 mètres de large sur 25 mètres de haut...

Celui de U2 !!!

Bon Week End
[ol]@+Thierry[/ol]

H - 25 = U 2

davidan · 8 Août 2005

merci ça a super bien marché pour l'initialisatio mais je me retrouve incapable de l'appliquer au reste, mais je crois pas que se soit tellement mon histoire de date qui ralentisse mon code.
je pense que je dois scanner encore plusieur fois ma feuille.
si tu peut m'aider avec un bout de code car j'ai du mal à appliquer les indication que tu m'as donné.
merci d'avance

Private Sub bouton_OK_Click()
On Error Resume Next
Application.ScreenUpdating = False
If ComboBox1.Value = 'tous' Then
Range('G12').AutoFilter field:=7
Else
Range('G12').AutoFilter field:=7, Criteria1:=ComboBox1.Value
End If
If ComboBox2.Value = 'tous' Then
Range('K12').AutoFilter field:=11
Else
Range('K12').AutoFilter field:=11, Criteria1:=ComboBox2.Value
End If
If ComboBox3.Value = 'tous' Then
Range('C12').AutoFilter field:=3
Else
Range('C12').AutoFilter field:=3, Criteria1:=ComboBox3.Value
End If
If ComboBox4.Value = 'tous' Then
Range('D12').AutoFilter field:=4
Else
Range('D12').AutoFilter field:=4, Criteria1:=ComboBox4.Value
End If
If ComboBox5.Value = 'tous' Then
Selection.AutoFilter field:=12
Else
Range('feuil1!L12').AutoFilter field:=12
Range('feuil1!L12:L65536').NumberFormat = '0'
Range('feuil2!A1').Value = ComboBox5.Value
Range('feuil2!A1') = CDate(ComboBox5.Value)
Range('feuil2!A1').NumberFormat = 'dd/mm/yy'
Range('feuil2!A1').Font.ColorIndex = 35
Range('L12').AutoFilter field:=12, Criteria1:=Range('feuil2!A1')
Range('L12') = ''
End If

If ComboBox5.Value = 'non émise' Then
Range('feuil1!L12').AutoFilter field:=12, Criteria1:=Empty
End If

If ComboBox6.Value = 'tous' Then
Range('M12').AutoFilter field:=13
Else
Range('feuil1!M12').AutoFilter field:=13
Range('feuil1!M12:M65536').NumberFormat = '0'
Range('feuil2!B1').Value = ComboBox6.Value
Range('feuil2!B1') = CDate(ComboBox6.Value)
Range('feuil2!B1').NumberFormat = 'dd/mm/yy'
Range('feuil2!B1').Font.ColorIndex = 35
Range('M12').AutoFilter field:=13, Criteria1:=Range('feuil2!B1')
Range('M12') = ''
End If

If ComboBox6.Value = 'non levée' Then
Range('feuil1!M12').AutoFilter field:=13, Criteria1:=Empty
End If

If ComboBox7.Value = 'tous' Then
Range('N12').AutoFilter field:=14
Else
Range('feuil1!N12').AutoFilter field:=14
Range('feuil1!N12:N65536').NumberFormat = '0'
Range('feuil2!C1').Value = ComboBox7.Value
Range('feuil2!C1') = CDate(ComboBox7.Value)
Range('feuil2!C1').NumberFormat = 'dd/mm/yy'
Range('feuil2!C1').Font.ColorIndex = 35
Range('M12').AutoFilter field:=14, Criteria1:=Range('feuil2!C1')
Range('M12') = ''
End If

If ComboBox7.Value = 'non contrôlée' Then
Range('feuil1!L14').AutoFilter field:=14, Criteria1:=Empty
End If

Range('feuil1!L12:L65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!M12:M65536').NumberFormat = 'dd/mm/yy'
Range('feuil1!N12:N65536').NumberFormat = 'dd/mm/yy'

Range('A12').Select
ActiveCell.FormulaR1C1 = 'tous'
Selection.AutoFill Destination:=Range('A12:Q12'), Type:=xlFillDefault
Unload UserForm1
End Sub

voila le fameux code qui prend temps de temps.
merci de ton aide

_Thierry · 8 Août 2005

Bonjour Davidan, Hervé, le Forum

Tu joues au jeu des septs erreurs ? car je ne vois pas de différence entre ton code posté le 3/8/05 16:49 et celui justre maintenant !

Je t'ai déjà expliqué ce qui ralentit ton code c'est ce genre de ''Barbartruc' :

Range('feuil1!L12').AutoFilter field:=12
Range('feuil1!L12:L65536').NumberFormat = '0'
Range('feuil2!A1').Value = ComboBox5.Value
Range('feuil2!A1') = CDate(ComboBox5.Value)
Range('feuil2!A1').NumberFormat = 'dd/mm/yy'
Range('feuil2!A1').Font.ColorIndex = 35
Range('L12').AutoFilter field:=12, Criteria1:=Range('feuil2!A1')
Range('L12') = ''

Car tu vas, en plus de filtrer, appliquer un format sur 65536 cellules....

Je t'ai donné le code plus haut pour travailler directement en date sur les AutoFilters, il suffit de t'en inspirer un peu comme ceci (NB Sans tester car sans Fichier témoin):

Dim WS As Worksheet 'Une seule fois en top de Sub...
Dim MyDate As Date 'Idem
Set WS = Sheets('Feuil1') 'Idem

With WS 'En Début de Procédure....

'Dans la Sub à la place du 'Barbartruc'
MyDate = CDate(ComboBox5.Value)
.Range('L12').AutoFilter Field:=12, Criteria1:='>=' & Format(MyDate, 'mm/dd/yy'), _
Operator:=xlAnd, Criteria2:='<=' & Format(MyDate, 'mm/dd/yy')

End With 'En Fin de Procédure....

Maintenant tu auras de toute manière un certain temps de réponse, mais si tu arrives à ne pas formater tes cellules ce devrait être bien mieux...

Bon Courage
[ol]@+Thierry[/ol]

davidan · 8 Août 2005

merci j'essaye!
encore une fois je sais pas ce que je ferai sans toi.

Effectuez une recherche sur Excel Downloads...

accélération d'un code VBA

davidan

XLDnaute Nouveau

_Thierry

XLDnaute Barbatruc

Hervé

XLDnaute Barbatruc

Hervé

XLDnaute Barbatruc

_Thierry

XLDnaute Barbatruc

Hervé

XLDnaute Barbatruc

davidan

XLDnaute Nouveau

_Thierry

XLDnaute Barbatruc

davidan

XLDnaute Nouveau

_Thierry

XLDnaute Barbatruc

_Thierry

XLDnaute Barbatruc

davidan

XLDnaute Nouveau

_Thierry

XLDnaute Barbatruc

davidan

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums