Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
951 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  accélération d'un code VBA

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

accélération d'un code VBA

n°1169086
davidan
Posté le 03-08-2005 à 16:46:28  profilanswer
 

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
 
 
 

mood
Publicité
Posté le 03-08-2005 à 16:46:28  profilanswer
 

n°1169242
gatsusat
Posté le 03-08-2005 à 18:33:42  profilanswer
 

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

n°1169953
mfauxock
Posté le 04-08-2005 à 15:45:32  profilanswer
 

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

n°1169956
mfauxock
Posté le 04-08-2005 à 15:47:05  profilanswer
 

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

n°1170059
mfauxock
Posté le 04-08-2005 à 17:19:53  profilanswer
 

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

n°1170095
davidan
Posté le 04-08-2005 à 17:55:44  profilanswer
 

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

n°1170362
jpcheck
Pioupiou
Posté le 05-08-2005 à 09:27:27  profilanswer
 

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

n°1170402
AlainTech
Pas trouvé? Cherche encore!
Posté le 05-08-2005 à 10:00:57  profilanswer
 

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!
n°1171604
slot_error
Posté le 07-08-2005 à 13:14:32  profilanswer
 

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


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  accélération d'un code VBA

 

Sujets relatifs
Convention - Normalisation du code ?Assombrissement/Obfuscation de code. Comment ? Quels Outils ?
[VBA][EXC] Fonction de recalcul d'une feuille Excel sous VBA ?VBA Excel: problème de compatibilité excel 2000 - excel 2003
Code : convention d'écritureApi Windows : Cherche code complet pour GetOpenFileName(...)
Initialisation complexe d'une variable globale ("code static")Recherche code html pour fondu ???
VBA EXCEL. Faire attendre la fin d'une query pour continuer.[VBA] Access, probleme de requete
Plus de sujets relatifs à : accélération d'un code VBA


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR