Optimisation temps d'exécution macro - remplir tableau via userform

Le 20/07/2020 à 22:32

Bonjour,

Je souhaiterai avoir vos conseils pour améliorer la macro suivante. Son temps d'exécution est d'environ 15 secondes. Merci pour votre aide

Private Sub CommandButton1_Click()

Application.EnableEvents = False

Dim sh As Worksheet
Dim tsh As Worksheet
Set sh = ThisWorkbook.Sheets("Data_source")
Set tsh = ThisWorkbook.Sheets("Tasks_ref")

'défini la ligne où seront insérées les nouvelles données
Dim lr As Long
Dim lrt As Long
If Me.BoInsert.Value = "" Then
lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
sh.ListObjects("Data_tab").ListRows.Add
End If
'Copier coller la ligne précédente pour récupérer les formules des cellules calculées
sh.Range("A" & lr - 1).EntireRow.Copy
sh.Range("A" & lr).PasteSpecial xlPasteAll

'insérer les valeurs mises dans les boxes du formulaire dans le tableau data_tab
sh.Range("B" & lr).Value = 7
sh.Range("D" & lr).Value = "legumes"
sh.Range("E" & lr).Value = Me.cboLots.Value
sh.Range("F" & lr).Value = Me.cboZone.Value
sh.Range("H" & lr).Value = Me.cboQui.Value
sh.Range("I" & lr).Value = Me.cboType.Value
sh.Range("K" & lr).Value = Me.tboDescription.Value
sh.Range("L" & lr).Value = Me.cboJalons.Value
sh.Range("AN" & lr).Value = Me.tboStart.Value
sh.Range("AO" & lr).Value = Me.tboEnd.Value
sh.Range("AP" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[Actual Start]];[@[Actual End]];Tableau22)"
sh.Range("AS" & lr).Value = Me.tboStart.Value
sh.Range("AT" & lr).Value = Me.tboEnd.Value
sh.Range("AU" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[Actual Start]];[@[Actual End]];Tableau22)"
sh.Range("AQ" & lr).Value = Me.tboProgress.Value
sh.Range("AV" & lr).Value = Me.tboProgress.Value

'ajout de la nouvelle ligne dans feuille Tasks_ref: tableau tasks_tab
lrt = tsh.Cells(tsh.Rows.Count, "A").End(xlUp).Row
sh.ListObjects("Data_tab").ListRows.Add
sh.Range("A" & lr).EntireRow.Copy
tsh.Range("A" & lrt).PasteSpecial xlPasteAll

MsgBox "Done", vbInformation

Unload Me

Application.EnableEvents = True

End Sub
Le 21/07/2020 à 05:08

Bonjour,

Peux-tu poster le fichier (anonymisé) ? cela permettrait de déterminer les parties chronophages

Pour moi, l'hypothèse la plus probable, ce sont les 2 lignes

sh.Range("AP" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[Actual Start]];[@[Actual End]];Tableau22)"
sh.Range("AU" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[Actual Start]];[@[Actual End]];Tableau22)"

Il n'est pas nécessaire de reproduire ces formules à chaque ligne, un tableau le fait automatiquement : une nouvelle ligne hérite d'un certain nombre de propriétés des lignes précédentes. Et il est fort probable que puisque tu les répètes, excel les recalcule pour toutes les lignes du tableau.

Le 21/07/2020 à 10:52

Bonjour,

Je te remercie pour ta réponse. Le fichier anonymisé est joint.

Je vais essayer en supprimant les [@xxx] de mes tableaux par les noms de cellules pour l'empêcher de recalculer tout à chaque fois.

13fichier.zip (1.32 Mo)
Le 21/07/2020 à 11:48
Koalapo a écrit :

Bonjour,

Je vais essayer en supprimant les [@xxx] de mes tableaux par les noms de cellules pour l'empêcher de recalculer tout à chaque fois.

Non, fais le sur la toute première ligne, la toute première fois, à la main si besoin. Ensuite elle sera reproduite. Ne le fais pas en remplaçant par les noms des cellules cela ne changerait rien !

Le 21/07/2020 à 13:12

Il a plein d'erreurs #REF! dans le fichier.

Essaie simplement comme ceci sans rien changer d'autre

Private Sub CommandButton1_Click()

Application.EnableEvents = False

If Me.tboDescription.Value = "" Then
   MsgBox "Please enter", vbCritical, "add new action"
   Exit Sub
End If

If Me.cboQui.Value = "" Then
   MsgBox "Please enter ", vbCritical, "add new action"
   Exit Sub
End If

If Me.cboJalons.Value = "" Then
   MsgBox "Please enter", vbCritical, "add new action"
   Exit Sub
End If

Dim sh As Worksheet
Dim tsh As Worksheet
Set sh = ThisWorkbook.Sheets("Data_source")
Set tsh = ThisWorkbook.Sheets("Tasks_ref")

'défini la ligne où seront insérées les nouvelles données
Dim lr As Long
Dim lrt As Long

lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'Application.CountA(sh.Range("K:K")) + 1
sh.ListObjects("Data_tab").ListRows.Add

'Copier coller la ligne précédente pour récupérer les formules des cellules calculées
sh.Range("A" & lr - 1).EntireRow.Copy
sh.Range("A" & lr).PasteSpecial xlPasteAll

'insérer les valeurs mises dans les boxes du formulaire dans le tableau data_tab
sh.Range("B" & lr).Value = 7
sh.Range("D" & lr).Value = "legumes"
sh.Range("E" & lr).Value = Me.cboLots.Value
sh.Range("F" & lr).Value = Me.cboZone.Value
sh.Range("H" & lr).Value = Me.cboQui.Value
sh.Range("I" & lr).Value = Me.cboType.Value
sh.Range("K" & lr).Value = Me.tboDescription.Value
sh.Range("L" & lr).Value = Me.cboJalons.Value
sh.Range("AN" & lr).Value = Me.tboStart.Value
sh.Range("AO" & lr).Value = Me.tboEnd.Value
'sh.Range("AP" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];tableau22)"
sh.Range("AS" & lr).Value = Me.tboStart.Value
sh.Range("AT" & lr).Value = Me.tboEnd.Value
'sh.Range("AU" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];Tableau22)"
sh.Range("AQ" & lr).Value = Me.tboProgress.Value
sh.Range("AV" & lr).Value = Me.tboProgress.Value

'ajout de la nouvelle ligne dans feuille Tasks_ref: tableau tasks_tab
lrt = tsh.Cells(tsh.Rows.Count, "A").End(xlUp).Row
'Application.CountA(tsh.Range("K:K")) + 1
sh.ListObjects("Data_tab").ListRows.Add
sh.Range("A" & lr).EntireRow.Copy
tsh.Range("A" & lrt).PasteSpecial xlPasteAll

ThisWorkbook.Sheets("Tasks_ref").Select

MsgBox "Task added successfully", vbInformation

Unload Me

Application.EnableEvents = True

End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub
Le 21/07/2020 à 16:25

J'aurais quand même bien aimé avoir un fichier "opérationnel" pour en faire l'analyse.

Le 21/07/2020 à 20:04

Bonjour,

Merci pour tes réponses. Je vais faire le ménage dans le fichier pour qu’il soit propre demain.

J’avais entre-temps supprimer tous les @xxx et ça a déjà divisé par deux le temps. J’ai fait un test en supprimant les deux lignes qui te semblaient poser pb mais le temps est resté sensiblement pareil.

Merci pour ton aide et je fais un fichier plus propre.

Le 22/07/2020 à 19:05

Bonjour,

J'ai remis le fichier au propre.

Le fichier comporte Trois Feuil :

- Data_Source qui regroupent l'ensemble des données,

- SupData qui regroupent les listes pour faire des validations dans les cellules de la Data_Source

- Tasks ref qui affiche que certains éléments de la Data_Source. Deux Icones en haut de cette feuille lancent deux macros. Une qui actualise les données et une qui ajoute une activité à travers d'un userform. C'est cette macro qui est lente dans l'exécution. Elle permet d'enregistrer la nouvelle ligne ligne à la fois dans la Feuil data_Source et la Feuil Tasks_ref.

29fichier.zip (1.31 Mo)
Le 23/07/2020 à 06:20

J'ai ajouté un compteur de temps et en effet !

capture d ecran 710

Sujet très intéressant ... cela risque de prendre un peu de temps mais je vais m'y pencher !

Le 23/07/2020 à 06:34

En ajoutant,

Debug.Print "#x: " & Format(Now - topdebut, "hh:mm:ss")

avec x plusieurs valeurs, on a :

#1 : 00:00:03
#2 : 00:00:22
#3 : 00:00:22
#4 : 00:00:23

on s'aperçoit que 95% du temps est pris par ceci :

'insérer les valeurs mises dans les boxes du formulaire dans le tableau data_tab
sh.Range("B" & lr + 1).Value = 7
sh.Range("D" & lr + 1).Value = "legumes"
sh.Range("E" & lr + 1).Value = Me.cboLots.Value
sh.Range("F" & lr + 1).Value = Me.cboZone.Value
sh.Range("H" & lr + 1).Value = Me.cboQui.Value
sh.Range("I" & lr + 1).Value = Me.cboType.Value
sh.Range("K" & lr + 1).Value = Me.tboDescription.Value
sh.Range("L" & lr + 1).Value = Me.cboJalons.Value
sh.Range("AN" & lr + 1).Value = Me.tboStart.Value
sh.Range("AO" & lr + 1).Value = Me.tboEnd.Value
'sh.Range("AP" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];tableau22)"
sh.Range("AS" & lr + 1).Value = Me.tboStart.Value
sh.Range("AT" & lr + 1).Value = Me.tboEnd.Value
'sh.Range("AU" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];Tableau22)"
sh.Range("AQ" & lr + 1).Value = Me.tboProgress.Value
sh.Range("AV" & lr + 1).Value = Me.tboProgress.Value

Ce qui signifie que ce qui est chronophage, ce sont les formules de calcul dans la feuille ... à investiguer (je continuerai plus tard)

Le 23/07/2020 à 07:18

Les MFC qui se rajoutent au fur et a mesure des recopies peuvent gêner le déroulement ... c'est déjà une hypothèse que j'ai écartée ici.

Le 23/07/2020 à 07:42

J'ai enlevé tous les calculs ... le temps tombe à moins de 1 secondes !

Je n'ai pas encore pu déterminer quel calcul était en cause (d'autant que certaines formules ne sont pas disponibles chez moi), en tous cas ce n'est pas la macro !

Le 23/07/2020 à 07:54

In fine la solution la plus simple est quand même dans la macro. 2 lignes ajoutées ici :

Application.Calculation = xlCalculationManual
topdebut = Now
Dim sh As Worksheet
Dim tsh As Worksheet
Set sh = ThisWorkbook.Sheets("Data_source")
Set tsh = ThisWorkbook.Sheets("Tasks_ref")

et en final, une ligne ajoutée et une modifiée

tsh.ListObjects("Tasks_tab").ListRows.Add
sh.Range("A" & lr + 1).EntireRow.Copy
tsh.Range("A" & lrt + 1).PasteSpecial xlPasteAll
Application.Calculation = xlCalculationAutomatic
MsgBox "Task added successfully in " & Format(Now - topdebut, "hh:mm:ss"), vbInformation
Le 23/07/2020 à 09:24

Bonjour,

Merci pour ton aide précieuse.

Avec ce que tu m'as dit, j'ai donc contourné le problème en créant une ligne en dehors du tableau puis j'ai recopié la ligne entière dans data_tab et tasks_tab. La macro tourne en deux secondes. Le problème est non identifié mais au moins le temps est divisé par dix :)

Private Sub CommandButton1_Click()

Application.EnableEvents = False

If Me.tboDescription.Value = "" Then
   MsgBox "Please enter", vbCritical, "add new action"
   Exit Sub
End If

If Me.cboQui.Value = "" Then
   MsgBox "Please enter ", vbCritical, "add new action"
   Exit Sub
End If

If Me.cboJalons.Value = "" Then
   MsgBox "Please enter", vbCritical, "add new action"
   Exit Sub
End If

Application.Calculation = xlCalculationManual
topdebut = Now
Dim sh As Worksheet
Dim tsh As Worksheet
Set sh = ThisWorkbook.Sheets("Data_source")
Set tsh = ThisWorkbook.Sheets("Tasks_ref")

'défini la ligne où seront insérées les nouvelles données
Dim lr As Long
Dim lrt As Long

lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

sh.ListObjects("Data_tab").ListRows.Add
Debug.Print "1 :" & Format(Now - topdebut, "hh:mm:ss")
'Copier coller la ligne précédente pour récupérer les formules des cellules calculées
sh.Range("A" & lr).EntireRow.Copy
sh.Range("A" & lr + 6).PasteSpecial xlPasteAll
'insérer les valeurs mises dans les boxes du formulaire dans le tableau data_tab
sh.Range("B" & lr + 6).Value = 7
sh.Range("D" & lr + 6).Value = "legumes"
sh.Range("E" & lr + 6).Value = Me.cboLots.Value
sh.Range("F" & lr + 6).Value = Me.cboZone.Value
sh.Range("H" & lr + 6).Value = Me.cboQui.Value
sh.Range("I" & lr + 6).Value = Me.cboType.Value
sh.Range("K" & lr + 6).Value = Me.tboDescription.Value
sh.Range("L" & lr + 6).Value = Me.cboJalons.Value
sh.Range("AN" & lr + 6).Value = Me.tboStart.Value
sh.Range("AO" & lr + 6).Value = Me.tboEnd.Value
'sh.Range("AP" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];tableau22)"
sh.Range("AS" & lr + 6).Value = Me.tboStart.Value
sh.Range("AT" & lr + 6).Value = Me.tboEnd.Value
'sh.Range("AU" & lr).FormulaLocal = "=NB.JOURS.OUVRES([@[S]];[@[T]];Tableau22)"
sh.Range("AQ" & lr + 6).Value = Me.tboProgress.Value
sh.Range("AV" & lr + 6).Value = Me.tboProgress.Value
'ajout de la nouvelle ligne dans feuille Tasks_ref: tableau tasks_tab
lrt = tsh.Cells(tsh.Rows.Count, "A").End(xlUp).Row

sh.Range("A" & lr + 6).EntireRow.Copy
sh.Range("A" & lr + 1).PasteSpecial xlPasteAll
sh.Range("A" & lr + 6).EntireRow.Delete

tsh.ListObjects("Tasks_tab").ListRows.Add
sh.Range("A" & lr + 1).EntireRow.Copy
tsh.Range("A" & lrt + 1).PasteSpecial xlPasteAll
Application.Calculation = xlCalculationAutomatic
MsgBox "Task added successfully in " & Format(Now - topdebut, "hh:mm:ss"), vbInformation
MsgBox "Task added successfully", vbInformation

Unload Me

Application.EnableEvents = True

End Sub
Le 23/07/2020 à 10:01

Re-bonjour,

J'ai converti mon tableau data_tab en plage de données classique. La macro se déroule en moins d'une seconde.

Je vais modifier mon autre macro pour conserver des data en simple plage de données.

Merci encore pour ton appui. Je mets le sujet en résolu :)

Rechercher des sujets similaires à "optimisation temps execution macro remplir tableau via userform"