Simplification de code

treza88

treza88

XLDnaute Occasionnel
Bonjour à tous

Je cherche a simplifier un code d'une proceduer sur un bouton ok d'une userform car j'ai un temps d'attente entre chaque saisie ce qui n'est pas l'ideal pour de la saisie.

J'ai essyé de supprimer au maximum les select, mais apres je bloc.

Voici mon code:

Code: 
Private Sub Ok_Click()
Application.ScreenUpdating = False
If longueur.Text = "" Then
MsgBox ("Vous n'avez rien saisi !")
Else
'transfert des données vers les cellules
With ActiveCell
.Value = Reference.Text
.Offset(0, 1).Value = designation.Text
.Offset(0, 2).Value = nombre.Text
End With
    Dim Longu As Currency, Larg As Currency
Longu = Val(longueur.Text)
Larg = Val(largeur.Text)
    If Longu > Larg Then
        ActiveCell.Offset(0, 4).Value = longueur.Text
        If Chb_surcote = True And Dim_surcote_Long.Text <> 0 Then
        Call Surcote(ActiveCell.Offset(0, 22))
        ActiveCell.Offset(0, 28).Value = Dim_surcote_Long.Text
 End If
       
        ActiveCell.Offset(0, 5).Value = largeur.Text
        If Chb_surcote = True And Dim_Surcote_larg.Text <> 0 Then
        Call Surcote(ActiveCell.Offset(0, 23))
        ActiveCell.Offset(0, 29).Value = Dim_Surcote_larg.Text
 End If
       
    Else
        ActiveCell.Offset(0, 4).Value = largeur.Text
        If Chb_surcote = True And Dim_surcote_Long.Text <> 0 Then
        Call Surcote(ActiveCell.Offset(0, 22))
        ActiveCell.Offset(0, 28).Value = Dim_surcote_Long.Text
 End If
        
        ActiveCell.Offset(0, 5).Value = longueur.Text
        If Chb_surcote = True And Dim_Surcote_larg.Text <> 0 Then
        Call Surcote(ActiveCell.Offset(0, 23))
        ActiveCell.Offset(0, 29).Value = Dim_Surcote_larg.Text
 End If
       
    End If
ActiveCell.Offset(0, 8).Value = SensFil.Text
   
ActiveCell.Offset(1, 0).Select
'remet tous les textbox a zero de la user form
Dim Ctrl As Control
  
For Each Ctrl In Me.Controls
    If TypeOf Ctrl Is MSForms.TextBox Then Ctrl.Value = ""
Next
'--------------------------------------------
'ajout automatique d'une ligne au tableau
Dim r As Integer, s As Integer, q As Integer, p As Integer
q = ActiveCell.Row ' N°de ligne en dessous de la derniere ligne saisi
Set firstCell = Range("F5") ' colonne avec formule mais pas de donnée
Set lastCell = Range("F65536").End(xlUp)
p = Range(lastCell, lastCell).Row ' Dernier N° de ligne du tableau
If p = q + 1 Then
    Range(lastCell, lastCell).Select
        r = ActiveCell.Row
        ActiveCell.Offset(1, 0).EntireRow.Select
        s = ActiveCell.Row
        Selection.Insert Shift:=xlDown
        Rows(r).Select
        Rows(r).Copy Rows(s)
End If
'reselection de la cellule d'entrée de donnée
Set firstCell = Range("D5")
Set lastCell = Range("D65536").End(xlUp)
Range(lastCell, lastCell).Offset(1, -1).Select
End If
Reference.SetFocus 'reactive la combobox reference
Application.Calculate
Application.ScreenUpdating = True
Set lastCell = Range("D65536").End(xlUp)
lastCell.Select
ActiveCell.Offset(1, -1).Select
Dim Ligne As Integer, Colonne As Integer
Ligne = lastCell.Row - 29
If Ligne >= 0 Then
With ActiveWindow
.ScrollRow = Ligne + 1
End With
End If
End Sub
 
Private Sub UserForm_Activate()
If ActiveSheet.Index < 4 Or (ActiveSheet.Index Mod 2) = 0 Or Worksheets.Count = ActiveSheet.Index Then
    MsgBox "Attention mauvaise selection, aucune saisie ne peut se faire sur cette feuille!"
    Zone2.Hide
    Exit Sub
End If
Num = ActiveSheet.Index
NomFeuille.ListIndex = ((Num - 1) / 2) - 2
Reference.ListIndex = ind
Reference.SetFocus
Set lastCell = Range("D65536").End(xlUp)
lastCell.Select
ActiveCell.Offset(1, -1).Select
Dim Ligne As Integer, Colonne As Integer
Ligne = lastCell.Row - 29
If Ligne >= 0 Then
With ActiveWindow
.ScrollRow = Ligne + 1
End With
End If
End Sub

Si quelqu'un peut me donner un coup de main, merci d'avance
 
Trier par date Trier par votes
Etienne2323

Etienne2323

XLDnaute Impliqué
Re : Simplification de code

Salut treza,
à mes yeux, ce code semble bien structuré et je ne crois pas que tu puisses gagner beaucoup de temps d'exécution par une réécriture plus concise de ce code. Ceci dit, c'est mon opinion. Je suis toutefois convaincu que les as du VBA pourront quand même te remodeler ça pour obtenir la structure la plus efficace.

D'ici là, voici quelques pistes de solutions qui pourraient t'aider.

1) Essaye d'enlever le calcul automatique en début de code
Code: 
Application.Calculation = xlCalculationManual
Tu dois par contre le remettre en fin de code :
Code: 
Application.Calculation = xlCalculationAutomatic

2) Vérifie s'il y a des macros évènementielles qui sont lancées par ce code. Si c'est le cas, alors peut-être qu'un
Code: 
Application.EnableEvents = False
en début de code et un
Code: 
Application.EnableEvents = True
en fin de code pourrait t'aider.

3) En postant un fichier exemple, il est beaucoup plus facile de tester et de pouvoir déterminer où est-ce qu'on peut gagner du temps d'exécution.

À te relire pour plus,

Cordialement,

Étienne
 
Vote positif 0 Vote négatif
treza88

treza88

XLDnaute Occasionnel
Re : Simplification de code

Ok merci Etienne2323, je vais voir suivant tes pistes et voir ce que ça donne, pour ce qui est de mettre le fichier complet je ne suis pas contre , mais il faut que je verifie si une patie peut fonctionner toute seule car le fichier fait appel a un logiciel exterieur en exportant une partie des données.
Donc il faut que je regarde avant, en plus tout le code qui est dedant n'est certainement pas au top je ne suis pas un programmeur chevroné et j'ai eu de l'aide de different forum qui m'ont aider à le construire un peu bout a bout, meme si il y a quand meme de ma propre création et certainement pas la meilleur, mais ça fonctionne.
 
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Simplification de code

Bonjour Treza, Etienne:)

tu peux également te passer des "select" ou "activate", très rarement nécessaires en vba, par exemple ceci :
Code: 
Rows(r).Select
        Rows(r).Copy Rows(s)

deviendrait :
Code: 
Rows(r).Copy Rows(s)

bonne journée
@+
 
Vote positif 0 Vote négatif
treza88

treza88

XLDnaute Occasionnel
Re : Simplification de code

Merci à vous deux
Oui aparemment ça fonctionne mieux.
J'ai dejà retravailler une petite partie du code comme ceci.


http://www.developpez.net/forums/d1.../excel/macros-vba-excel/simplification-code/#
Code: 
Private Sub Ok_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If longueur.Text = "" Then
MsgBox ("Vous n'avez rien saisi !")
Else
'transfert des données vers les cellules
With ActiveCell
.Value = Reference.Text
.Offset(0, 1).Value = designation.Text
.Offset(0, 2).Value = nombre.Text
End With
Dim Longu As Currency, Larg As Currency
Longu = Val(longueur.Text)
Larg = Val(largeur.Text)
If Longu > Larg Then
ActiveCell.Offset(0, 4).Value = longueur.Text
If Chb_surcote = True And Dim_surcote_Long.Text <> 0 Then
Call Surcote(ActiveCell.Offset(0, 22))
ActiveCell.Offset(0, 28).Value = Dim_surcote_Long.Text
End If
ActiveCell.Offset(0, 5).Value = largeur.Text
If Chb_surcote = True And Dim_Surcote_larg.Text <> 0 Then
Call Surcote(ActiveCell.Offset(0, 23))
ActiveCell.Offset(0, 29).Value = Dim_Surcote_larg.Text
End If
Else
ActiveCell.Offset(0, 4).Value = largeur.Text
If Chb_surcote = True And Dim_surcote_Long.Text <> 0 Then
Call Surcote(ActiveCell.Offset(0, 22))
ActiveCell.Offset(0, 28).Value = Dim_surcote_Long.Text
End If
ActiveCell.Offset(0, 5).Value = longueur.Text
If Chb_surcote = True And Dim_Surcote_larg.Text <> 0 Then
Call Surcote(ActiveCell.Offset(0, 23))
ActiveCell.Offset(0, 29).Value = Dim_Surcote_larg.Text
End If
End If
ActiveCell.Offset(0, 8).Value = SensFil.Text
 
'remet tous les textbox a zero de la user form
Dim Ctrl As Control
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is MSForms.TextBox Then Ctrl.Value = ""
Next
'--------------------------------------------
'ajout automatique d'une ligne au tableau
Dim r As Integer, s As Integer, q As Integer, p As Integer
q = ActiveCell.Offset(1, 0).Row ' N°de ligne en dessous de la derniere ligne saisi
Set firstCell = Range("F5") ' colonne avec formule mais pas de donnée
Set lastCell = Range("F65536").End(xlUp)
p = Range(lastCell, lastCell).Row ' Dernier N° de ligne du tableau
If p = q + 1 Then
 
r = ActiveCell.Offset(1, 0).Row
s = ActiveCell.Offset(2, 0).Row
ActiveCell.Offset(2, 0).EntireRow.Insert Shift:=xlDown
Rows(r).Copy Rows(s)
 
End If
'reselection de la cellule d'entrée de donnée
Set firstCell = Range("D5")
Set lastCell = Range("D65536").End(xlUp)
Range(lastCell, lastCell).Offset(1, -1).Select
End If
Reference.SetFocus 'reactive la combobox reference
Application.ScreenUpdating = True
Set lastCell = Range("D65536").End(xlUp)
lastCell.Offset(1, -1).Select
 
Application.Calculation = xlCalculationAutomatic
 
Dim Ligne As Integer, Colonne As Integer
Ligne = lastCell.Row - 29
If Ligne >= 0 Then
ActiveWindow.ScrollRow = Ligne + 1
End If
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
Microsoft 365 Simplification code
Réponses
2
Affichages
145
Francky79
F
piga25
  • Résolu(e)
XL 2016 Gestion d'erreur dans code
Réponses
6
Affichages
213
piga25
piga25
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
350
dadu35
D
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
217
gui22
G
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
251
chaelie2015
chaelie2015
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
231
fanch55
fanch55
T
  • Question
Microsoft 365 Code VBA
Réponses
2
Affichages
321
thierry33670
T
N
  • Résolu(e)
XL 2021 erreur Vba
2
Réponses
21
Affichages
1 K
Oneida
Oneida
THOR57
  • Résolu(e)
XL 2016 If ActiveCell = "Contenu d'une TextBox" Then
2
Réponses
27
Affichages
722
TooFatBoy
TooFatBoy
H
  • Résolu(e)
sub en function
Réponses
2
Affichages
254
Hunter296
H

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 38 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 084
Membres
103 459
dernier inscrit
Arnocal