accélération d'un code VBA

accélération d'un code VBA - VB/VBA/VBS - Programmation

Marsh Posté le 03-08-2005 à 16:46:28    

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
'   auteur:David Ananian
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:D" & .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
'   auteur:David Ananian
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
'   auteur:David Ananian
    Unload UserForm1
End Sub
 
 
 

Reply

Marsh Posté le 03-08-2005 à 16:46:28   

Reply

Marsh Posté le 03-08-2005 à 18:33:42    

tu mettrais tout ce bordel entre 2 balises code ca serait mieux

Reply

Marsh Posté le 04-08-2005 à 15:45:32    

Plutot que d'utiliser les additem pour les combobox
ne peux tu pas utiliser les rowsource : ca va t'éviter les boucles

Reply

Marsh Posté le 04-08-2005 à 15:47:05    

Range("D12" & .Range("D65536" ).End(xlUp).Row)
à remplacer par (si possible)
 
Range("D12" & .Range("D12" ).End(xldown).Row)

Reply

Marsh Posté le 04-08-2005 à 17:19:53    

Pour remplir des combobox je te conseille également de faire des tableaux croisés dynamiques pour ne par avoir de répétition dans ta liste et même faire un classement par ordre alphabétique des valeur dans le tableau X dyn.
 
Si tu suis les trois conseils ça ira vachement plus vite

Reply

Marsh Posté le 04-08-2005 à 17:55:44    

merci je vai essayé mais je suis pas un expère de VBA voir plutot un débutant qui persévère!!!!

Reply

Marsh Posté le 05-08-2005 à 09:27:27    

perdre ses vers, c'est grave docteur?  :pt1cable:

Reply

Marsh Posté le 05-08-2005 à 10:00:57    

Il peut être plus grave de perdre ses verres...


---------------
Si on vous donne une info qui marche, DITES-LE!!!! ------ Si vous trouvez seul, AUSSI, votre solution peut servir à d'autres! ------ Je dois la majorité de mes connaissances à mes erreurs!
Reply

Marsh Posté le 07-08-2005 à 13:14:32    

salut, tu as une autre option pour accéler l'exécution du code qui est la désactivation du recalcul automatique. à n'utiliser bien sur que dans les passages ou tu n'as pas besoin de recalulculer le contenu des cellules.
-->  application.Calculation =xlCalculationManual pour mettre en manuel
-->  application.Calculation =xlCalculationAutomatic pour remettre en auto

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed