Réduction temps d'exécution macro ajout nouvelle ligne

Le 04/11/2017 à 15:58

Salut à tous,

J'espère que tous se porte bien.

Le code ci après me permet d'ajouter de nouvelles lignes dans un tableau mais au fur et à mesure que le nombre de ligne du tableau s'augmente, la macro met du temps à s'exécuter. J'aimerais que vous m'aidiez à corriger le code afin de réduire au maximum le temps d'exécution. Actuellement je suis à 8500 lignes et l'exécution de la macro prend 23 secondes.

Merci d'avance.

Private Sub AchatComptant_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    ' nouv_ligne achat comptant
    Range("A8").Select
    Selection.ListObject.ListRows.Add AlwaysInsert:=False
    Range("A8").End(xlDown).Offset(0, 1).Select

    ' ajouter date, heure & modalité automatiquement
   Selection.Value = Date
    Selection.Offset(0, 1).Select
   Selection.Value = Format(Time, "hh:mm:ss")
   Selection.Offset(0, 1).Select
   Selection.Value = "Comptant"
    Selection.Offset(0, 4).Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Le code suivant me permet de filtrer les cellules vides de mon tableau et actuellement son exécution fait environ 35 secondes

Sub filtreDATESvide()
'
' filtredatevide Macro
'

'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    On Error GoTo errorHandler
    ActiveSheet.ShowAllData
errorHandler:
    Application.ScreenUpdating = False
    Range("TABACHATS[DATES]").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.ListObjects("TABACHATS").Range.AutoFilter Field:=9, _
        Criteria1:="="
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Ce dernier me permet de désactiver les filtres et il prend aussi 35 secondes.

Sub defiltrertabACHATS()
'
' defiltrertabenregistrement Macro
'

'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    Range("TABACHATS[[#Headers],[DATES]]").Select
    On Error GoTo errorHandler
    ActiveSheet.ShowAllData
    Application.Goto Reference:="TABACHATS"
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
errorHandler:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

J'ai voulu joindre le fichier mais il est d'environ 1,5 Mo alors que le règlement du forum ne permet que des fichiers de 1 Mo.

Merci d'avance pour l'aide.

Le 04/11/2017 à 16:45

Bonjour,

Il faut éviter les Select et Activate si ils ne sont pas absolument nécessaires. Dans un tableau (ListObject) le fait d'inscrire une valeur dans une des cellules de la première ligne vide sous le tableau agrandi automatiquement le tableau il n'est donc pas nécessaire d'ajouter cette ligne par code. ton code devient alors :

Private Sub AchatComptant_Click()

    Dim Cel As Range

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Set Cel = Range("A8").End(xlDown).Offset(1)

    With Cel

        .Value = Date
        .Offset(0, 1).Value = Format(Time, "hh:mm:ss")
        .Offset(0, 2).Value = "Comptant"

    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

A faire de même pour les autres codes !

Le 04/11/2017 à 18:02

Salut Theze,

Merci pour ta réponse. Je suis ravis d'apprendre du nouveau mais la durée de l'exécution est toujours la même.

Le 04/11/2017 à 22:00

Re,

Si tu peux poster ton classeur sans données confidentielles ça serait peut être mieux pour déceler le ou les soucis !

Le 04/11/2017 à 22:06

Re,

Je veux bien le poster mais il fait environ 1,5 Mo alors que le règlement du forum ne permet que des fichiers de 1 Mo.

Y'a t-il un autre moyen de le poster ?

Merci

Le 04/11/2017 à 22:24

tu peux peut être le réduire, j'en augmenterai le volume par rapport aux données existantes pour en avoir le même nombre que toi

Le 04/11/2017 à 22:43

J'ai pu créer un lien vers mon classeur sur Cjoint

https://www.cjoint.com/c/GKevNJisLxq

Le 04/11/2017 à 23:15

Re,

C'est le nombre trop important de formules qui fait ramer ! Pour tester, j'ai fais une copie de ta feuille et j'ai remplacé les formules par les valeurs (copie de toute la feuille puis collage spécial --> Valeurs) et le code d'ajout est instantané !

Je crains que tu ne soit obligé de trouver une autre solution surtout si ton tableau est amené à grandir. Peut être une solution par VBA avec des valeurs directement écrites dans les cellules plutôt que des formules. Pour une mise à jour automatique, utiliser la procédure événementielle Worksheet_Change()

Le 04/11/2017 à 23:46

Ah oui je vois. Mais n'étant pas trop fort en VBA, je crains fort de ne pas pouvoir éditer des codes pouvant remplacer mes formules actuelles.

De quelle mise à jour parles tu ici

Pour une mise à jour automatique, utiliser la procédure événementielle Worksheet_Change()

Merci

Le 06/11/2017 à 06:43

Bonjour,

J'ai commencer un code pour remplacer tes formules par des macros donc, si tu n'es pas trop pressé, je pense te finir ça dans la semaine !

Le 06/11/2017 à 08:03

Merci beaucoup. Appelle moi patience, même pas pressé

J'attends alors

Le 07/11/2017 à 20:19

Bonjour à tous, bonjour vikled,

Je travaille sur ton classeur et la colonne S (MT_PAYE) contient la formule :

=SOMME.SI.ENS(#REF!;#REF!;TABACHATS[[#Cette ligne];[REFPJ]])

et comme tu peux voir, il y a un problème de référence dans la fonction SOMME.SI.ENS() pour l'argument "plage_somme" et "plage_critères1"

Peux-tu me donner ces arguments ?

Le 07/11/2017 à 20:46

Ah oui. Cette formule fait normalement référence à une autre feuille que j'ai supprimé par souci de diminuer la taille du fichier.

Voici la réelle formule.

=SOMME.SI.ENS(TABREGLEMENTS[PAIEMENT];TABREGLEMENTS[PIECES JUSTIFICATIVES];[@REFBJ])

Toutes mes excuses

Merci

Le 08/11/2017 à 06:15

Bonjour vikled, Theze

Il y a quelque chose que je n'ai pas compris, si tu utilise un tableau pourquoi as-tu besoin d'ajouter des lignes par VBA ?

En fait je me demande quel est l'objectif de ton code VBA !

Le 08/11/2017 à 07:20

Bonjour,

J'ai pondu un code qu'il faudrait que tu testes sur ton classeur complet. Dans un premier temps, les valeurs sont retournées dans des boites de messages précisant dans quelle colonne elles doivent se trouver.

Pour ce test, tu doit indiquer le numéro de ligne du tableau que tu souhaites tester et puis appui sur F5 dans le VBE :

Lig = 8 '<indiquer le numéro de la ligne du tableau à tester !

Adapte aussi le nom de la seconde feuille :

Set FeReglement = Worksheets("Feuil1") '<--- adapter le nom

Comme tu es le créateur du classeur, tu pourras mieux appréhender les résultats retournés, reviens avec tes conclusions afin qu'on trouve la solution la mieux adaptée :

Sub Test()

    'numéro de colonne
    Const MODALITE As Integer = 4
    Const REFPJ As Integer = 5
    Const A As Integer = 6
    Const REF As Integer = 7
    Const P_JUST As Integer = 8 'PIECE JUSTIFICATIVES
    Const DATES As Integer = 9
    Const FOURNISSEURS As Integer = 10
    Const MOTIFS As Integer = 11
    Const QTE As Integer = 12
    Const PRIX_UNIT As Integer = 13 'PRIX UNITAIRE
    Const DELAI As Integer = 14 'DELAI en jour
    Const TOTAL As Integer = 15
    Const ECHEANCES As Integer = 16
    Const VALEUR As Integer = 17
    Const ETAT As Integer = 18
    Const MT_PAYE As Integer = 19
    Const RAP As Integer = 20
    Const ECHEANCIERS As Integer = 21

    Const PAIEMENT As Integer = 1 '<---- à rectifier par rapport au tableau réel pour TABREGLEMENTS
    Const P_JUSTREGL As Integer = 2 '<---- à rectifier par rapport au tableau réel PIECES JUSTIFICATIVES pour TABREGLEMENTS

    Dim Tbl As ListObject
    Dim TblRegl As ListObject
    Dim FeAchats As Worksheet
    Dim FeReglement As Worksheet
    Dim Plage As Range
    Dim Plage2 As Range
    Dim Lig As Long
    Dim LigDeb As Long
    Dim NBLig As Long
    Dim Retour

    'variables objets pour les feuilles
    Set FeAchats = Worksheets("ACHATS")
    Set FeReglement = Worksheets("Feuil1") '<--- adapter le nom

    'variables objets pour les tableaux
    Set Tbl = FeAchats.ListObjects("TABACHATS")
    Set TblRegl = FeReglement.ListObjects("TABREGLEMENTS")

    Lig = 8 '<indiquer le numéro de la ligne du tableau à tester !
MsgBox "Les valeurs se trouvent en ligne " & Lig & " du tableau donc, en ligne " & Lig + 8 & " de la feuille !"

    'formule REFPJ colonne E
    If Tbl.DataBodyRange(Lig, MODALITE).Value = "Comptant" And Tbl.DataBodyRange(Lig, P_JUST).Value = "" Then
        Retour = ""
    Else
        Retour = Tbl.DataBodyRange(Lig, P_JUST).Value & " du " & Format(Tbl.DataBodyRange(Lig, DATES).Value, "dd mmm yy") & " " & Tbl.DataBodyRange(Lig, FOURNISSEURS).Value
    End If
MsgBox "Valeur à mettre en colonne E :" & vbCrLf & vbCrLf & Retour

    'formule A colonne F
    With FeAchats: Set Plage = .Range(.Cells(9, REFPJ), .Cells(.Rows.Count, REFPJ).End(xlUp)): End With
    If Tbl.DataBodyRange(Lig, REFPJ).Value = "" Or Application.CountIf(Range("E9", Tbl.DataBodyRange(Lig, REFPJ)), Tbl.DataBodyRange(Lig, REFPJ).Value) > 1 Then
        Retour = ""
    Else
        Retour = Application.CountIf(Plage, ">=" & Tbl.DataBodyRange(Lig, REFPJ).Value)
    End If
MsgBox "Valeur à mettre en colonne F :" & vbCrLf & vbCrLf & Retour

    'formule REF colonne G
    With FeAchats: Set Plage = .Range(.Cells(9, A), .Cells(.Rows.Count, A).End(xlUp)): End With
    With FeAchats: Set Plage2 = .Range(.Cells(9, REFPJ), .Cells(.Rows.Count, REFPJ).End(xlUp)): End With
    If Lig > Application.Count(Plage) Then
        Retour = "#N/A"
    Else
        Retour = Application.Index(Plage2, Application.Match(Application.Large(Plage, Lig), Plage, 0))
    End If
MsgBox "Valeur à mettre en colonne G :" & vbCrLf & vbCrLf & Retour

    'formule TOTAL colonne O
    Retour = Tbl.DataBodyRange(Lig, QTE).Value * Tbl.DataBodyRange(Lig, PRIX_UNIT).Value
MsgBox "Valeur à mettre en colonne O :" & vbCrLf & vbCrLf & Retour

    'formule ECHEANCES colonne P
    If Tbl.DataBodyRange(Lig, DATES).Value = "" Then
        Retour = ""
    Else
        Retour = Tbl.DataBodyRange(Lig, DATES).Value + Tbl.DataBodyRange(Lig, DELAI).Value
    End If
MsgBox "Valeur à mettre en colonne P :" & vbCrLf & vbCrLf & Retour

    'formule VALEUR colonne Q
    With FeAchats: Set Plage = .Range(.Cells(9, 5), .Cells(.Rows.Count, 5).End(xlUp)): End With
    With FeAchats: Set Plage2 = .Range(.Cells(9, 15), .Cells(.Rows.Count, 15).End(xlUp)): End With
    If Tbl.DataBodyRange(Lig, REFPJ).Value = "" Then
        Retour = ""
    Else
        Retour = Application.SumIf(Plage, Tbl.DataBodyRange(Lig, REFPJ).Value, Plage2)
    End If
MsgBox "Valeur à mettre en colonne Q :" & vbCrLf & vbCrLf & Retour

    'formule ETAT colonne R
    If Tbl.DataBodyRange(Lig, MODALITE).Value = "Comptant" Then
        Retour = "Soldé"
    ElseIf Tbl.DataBodyRange(Lig, VALEUR).Value = Tbl.DataBodyRange(Lig, MT_PAYE).Value Then
        Retour = "Soldé"
    ElseIf Tbl.DataBodyRange(Lig, MT_PAYE).Value > 0 Then
        Retour = "Partiel"
    ElseIf Tbl.DataBodyRange(Lig, MT_PAYE).Value = 0 Then
        Retour = "Impayé"
    Else
        Retour = ""
    End If
MsgBox "Valeur à mettre en colonne R :" & vbCrLf & vbCrLf & Retour

    'formule MT_PAYE colonne S
    With FeReglement: Set Plage = .Range(.Cells(2, PAIEMENT), .Cells(.Rows.Count, PAIEMENT).End(xlUp)): End With
    With FeReglement: Set Plage2 = .Range(.Cells(9, P_JUSTREGL), .Cells(.Rows.Count, P_JUSTREGL).End(xlUp)): End With
    Retour = Application.SumIfs(Plage, Plage2, Tbl.DataBodyRange(Lig, REFPJ).Value)
On Error Resume Next
MsgBox "Valeur à mettre en colonne S :" & vbCrLf & vbCrLf & Retour 'erreur générée car je ne connais les valeurs à retournées !
On Error GoTo 0

    'formule RAP colonne T
    On Error Resume Next
    Retour = Tbl.DataBodyRange(Lig, VALEUR).Value - Tbl.DataBodyRange(Lig, MT_PAYE).Value
    If Err.Number <> 0 Then
        Retour = ""
    End If
    On Error GoTo 0
MsgBox "Valeur à mettre en colonne T :" & vbCrLf & vbCrLf & Retour

    'formule ECHEANCIERS colonne U
    If Tbl.DataBodyRange(Lig, ETAT).Value = "Soldé" Then
        Retour = "Soldé"
    Else
        If Date > Tbl.DataBodyRange(Lig, ECHEANCES).Value Then
            If Tbl.DataBodyRange(Lig, MODALITE).Value = "Crédit" Then
                Retour = "Échu"
            Else
                Retour = "Non échu"
            End If
        End If
    End If
MsgBox "Valeur à mettre en colonne U :" & vbCrLf & vbCrLf & Retour

End Sub
Le 22/11/2017 à 07:29
NCC 1701 a écrit :

Bonjour vikled, Theze

Il y a quelque chose que je n'ai pas compris, si tu utilise un tableau pourquoi as-tu besoin d'ajouter des lignes par VBA ?

En fait je me demande quel est l'objectif de ton code VBA !

Bonjour NCC 1701,

Salut à tous,

j'utilise le Vba puisque la feuille sera verrouillé pour éviter la modification de certaines cellules par l'utilisateur . De olus certaines données seront insérée automatiquement dès le clique sur le bouton d'ajout de ligne.

Bonjour Thez,

Grand merci pour le gros travail abattu. Toutes mes excuses, j'étais hors réseau entre temps. Je suis de retour maintenant. Je vais mettre le code en application et je vous ferai un retour très incessamment.

Une fois de plus merci.

Le 23/11/2017 à 14:08

Bonjour Theze,

J'ai appliqué le code et il fonctionne parfaitement [ il fait afficher dans des boîtes de message les données se trouvant dans les cellules de la ligne indiquée sauf les données de la colonne ( MT_PAYE) qui fait référence à la feuille règlement ]

Que faire pour la suite ?

En attendant le code actuel est impeccable surtout avec les annotations bien claires.

Rechercher des sujets similaires à "reduction temps execution macro ajout nouvelle ligne"