diminuer le temps d'exécution d'un macro vba

N

ndella02

XLDnaute Nouveau
bonjour à tous,
pouvez-vous m'indiquer comment diminuer le temps d'exécution de ce macro qui fait:
j'ai un classeur qui contient des feuilles la 1ère s'appelle "donnees. mon objectif est de remplir les autres feuilles à partir à condition que le nom de la feuille se trouve dans la 1ère plage de "donnees" et si la plage n°3 de "donnees" correspond aux plages n° 1 et 4 de la feuille

Sub remplirfeuille()

Dim Lst() As String
Dim j As Integer
Dim I As Integer
Dim N As Variant 'Integer
Dim l As Integer
Dim p As Integer
Dim temp1 As String
ReDim Lst(Sheets.Count - 1)
Dim debut As Date, temps As Date, fin As Date
debut = Time


Application.ScreenUpdating = False
Application.DisplayAlerts = False

N = Sheets("donnees").Range("A1").End(xlDown).Row

For I = 1 To Worksheets.Count
Lst(I) = Worksheets(I).Name
temp1 = Lst(I)

For j = 2 To N
If (Sheets("donnees").Cells(j, 1).Value = temp1) Then
For p = 5 To 306
If (Sheets(I).Cells(p, 1).Value = Sheets("donnees").Cells(j, 4).Value) Then
Sheets(I).Cells(p, 3).Value = -Sheets("donnees").Cells(j, 6).Value
ElseIf (Sheets(I).Cells(p, 6).Value = Sheets("donnees").Cells(j, 4).Value) Then
Sheets(I).Cells(p, 4).Value = Sheets("donnees").Cells(j, 6).Value
End If
Next p
End If
Next j
Next I
fin = Time
temps = fin - debut
MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)

End Sub

merci!
 

Pièces jointes

  • Classeur1.xls
    73 KB · Affichages: 110
  • Classeur1.xls
    73 KB · Affichages: 110
  • Classeur1.xls
    73 KB · Affichages: 103
Trier par date Trier par votes
francedemo

francedemo

XLDnaute Occasionnel
Re : diminuer le temps d'exécution d'un macro vba

bonjour,

6.5 s (avec qques modifs...)

si ça t'interesse:
Code: 
Sub remplirfeuille()

Dim Lst() As String
Dim j As Integer
Dim I As Integer
Dim N As Integer 'Integer
Dim l As Integer
Dim p As Integer
Dim temp1 As String
ReDim Lst(Sheets.Count - 1)
Dim debut As Long
Dim FDonnees As Worksheet

debut = Timer
  
Application.ScreenUpdating = False
Application.DisplayAlerts = False

N = Sheets("donnees").Range("A65536").End(xlUp).Row
Set FDonnees = Sheets("donnees")
FDonnees.Activate
For I = 1 To Worksheets.Count
   If I = Worksheets.Count Then Exit For
   With Worksheets(I)
      Lst(I) = .Name
      temp1 = Lst(I)

      For j = 2 To N
         If Cells(j, 1) = temp1 Then
            For p = 5 To 306
               If .Cells(p, 1).Value = Cells(j, 4).Value Then
                  .Cells(p, 3).Value = Cells(j, 6).Value
               ElseIf (Sheets(I).Cells(p, 6).Value = Cells(j, 4).Value) Then
                  .Cells(p, 4).Value = Cells(j, 6).Value
               End If
            Next p
         End If
      Next j
   End With
Next I
CreateObject("wscript.shell").popup "Terminé en " & Timer - debut & " secondes", 5, "durée"

End Sub
à+
 
Vote positif 0 Vote négatif
francedemo

francedemo

XLDnaute Occasionnel
Re : diminuer le temps d'exécution d'un macro vba

avec encore d'autres modifs (simplifications):
Code: 
Option Explicit
Sub remplirfeuille()

Dim j As Integer
Dim I As Integer
Dim N As Integer
Dim p As Integer
Dim debut As Long
Dim FDonnees As Worksheet

debut = Timer
  
With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
End With

N = Sheets("donnees").Range("A65536").End(xlUp).Row
Set FDonnees = Sheets("donnees")
FDonnees.Activate
For I = 1 To Worksheets.Count
   If I = Worksheets.Count Then Exit For
   With Worksheets(I)
      For j = 2 To N
         If Cells(j, 1) = .Name Then
            For p = 5 To 306
               If .Cells(p, 1).Value = Cells(j, 4).Value Then
                  .Cells(p, 3).Value = Cells(j, 6).Value
               ElseIf .Cells(p, 6).Value = Cells(j, 4).Value Then
                  .Cells(p, 4).Value = Cells(j, 6).Value
               End If
            Next p
         End If
      Next j
   End With
Next I
With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
End With
CreateObject("wscript.shell").popup "Terminé en " & Timer - debut & " secondes", 5, "durée"

End Sub

temps < 1s
à+
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : diminuer le temps d'exécution d'un macro vba

Bonjour à tous


Aucun des codes proposés ne semble faire le boulot. J'ai analysé le premier (message #1) et j'ai l'impression que les indices des colonnes sont fautifs.


À ndella02 : Avant de chercher à optimiser, pouvez-vous me dire si le code suivant fait ce qu'il faut dans le classeur du message #1 ?
Si tel n'est pas le cas, pouvez-vous compléter manuellement les douze premières lignes des feuilles de résultat pour qu'on comprenne ce que vous souhaitez y trouver ?

Merci d'avance.​



Code à essayer :
VB: 
Sub remplirfeuille()

    Dim j As Long
    Dim i As Integer
    Dim n As Long
    Dim p As Integer
    Dim Tmp As String
    Dim debut As Date, temps As Date, fin As Date

debut = Time

n = Sheets("donnees").Range("A1").End(xlDown).Row
 
For i = 2 To Worksheets.Count
Tmp = Worksheets(i).Name

    For j = 2 To n
       If (Sheets("donnees").Cells(j, 1).Value = Tmp) Then
        For p = 5 To 306
        If (Sheets(Tmp).Cells(p, 2).Value = Sheets("donnees").Cells(j, 3).Value) Then
            Sheets(Tmp).Cells(p, 3).Value = -Sheets("donnees").Cells(j, 6).Value
        ElseIf (Sheets(Tmp).Cells(p, 5).Value = Sheets("donnees").Cells(j, 3).Value) Then
            Sheets(Tmp).Cells(p, 6).Value = Sheets("donnees").Cells(j, 6).Value
        End If
        Next p
       End If
    Next j

Next i

fin = Time
temps = fin - debut
MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)

End Sub



ROGER2327
#6146

Samedi 7 Tatane 139 (Saint Biribi, taulier - fête Suprême Quarte)
2 Thermidor An CCXX, 6,7295h - bouillon-blanc
2012-W29-5T16:09:03Z
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : diminuer le temps d'exécution d'un macro vba

Re...


ndella02 à dit:
merci, j'avais fait une erreur mais le code fonctionne.
bon week end!
Cliquez pour agrandir...
Je n'avais pas vu ce message lorsque je rédigeais ma réponse.

Si vous avez maintenant un code fonctionnel, pouvez-vous le communiquer pour que je voie si j'avais compris ou non le problème ?
Merci d'avance !



ROGER2327
#6147

Samedi 7 Tatane 139 (Saint Biribi, taulier - fête Suprême Quarte)
2 Thermidor An CCXX, 6,7742h - bouillon-blanc
2012-W29-5T16:15:29Z
 
Vote positif 0 Vote négatif
N

ndella02

XLDnaute Nouveau
Re : diminuer le temps d'exécution d'un macro vba

effectivement il y avait une erreur sur les numéros de colonnes, le code fionctionne bien.

cordialement,

ROGER2327 à dit:
Re...


Je n'avais pas vu ce message lorsque je rédigeais ma réponse.

Si vous avez maintenant un code fonctionnel, pouvez-vous le communiquer pour que je voie si j'avais compris ou non le problème ?
Merci d'avance !



ROGER2327
#6147

Samedi 7 Tatane 139 (Saint Biribi, taulier - fête Suprême Quarte)
2 Thermidor An CCXX, 6,7742h - bouillon-blanc
2012-W29-5T16:15:29Z
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : diminuer le temps d'exécution d'un macro vba

Bonsoir à tous, re...


ndella02 à dit:
mis à part les numéros de colonnes, aucune modification n'a été faite sur le code
Cliquez pour agrandir...
Parfait. Dans ce cas, et toujours dans le classeur du message #1, un code environ 150 fois plus rapide :​
VB: 
Sub toto()
Dim i&, j&, k&, l&, LDat&, Ctmp$
Dim Dat(), LstFl As New Dictionary, Fl, FFl As Worksheet
Dim NCpte&, Deb(), Cre(), LibD(), LibC()

    Dat = Me.Range(Me.Cells(1, 6), Me.Cells(1, 1).End(xlDown)) 'Table de données
    LDat = UBound(Dat)
    For i = 2 To LDat
        If Not LstFl.Exists(CStr(Dat(i, 1))) Then LstFl.Add CStr(Dat(i, 1)), 1
    Next
    For Each Fl In LstFl.Keys
        On Error GoTo E
        Set FFl = Worksheets(Fl)
        On Error GoTo 0
        With FFl.Range(FFl.Cells(5, 1), FFl.Cells(FFl.Rows.Count, 1).End(xlUp)) 'N° de compte
            NCpte = .Count
            LibD = .Offset(0, 1).Value 'Libellé Débit
            LibC = .Offset(0, 4).Value 'Libellé Crédit
            ReDim Deb(1 To NCpte, 0)
            Cre = Deb
            For i = 2 To LDat
                If CStr(Dat(i, 1)) = Fl Then
                    Ctmp = Dat(i, 3)
                    For j = 1 To NCpte
                        If LibD(j, 1) = Ctmp Then
                            Deb(j, 0) = -Dat(i, 6)
                        ElseIf LibC(j, 1) = Ctmp Then
                            Cre(j, 0) = Dat(i, 6)
                        End If
                    Next
                End If
            Next
            .Offset(0, 2).Value = Deb 'Débit
            .Offset(0, 5).Value = Cre 'Crédit
        End With
RE: Next
Exit Sub
E:  'Feuille manquante
    Resume RE
End Sub



ROGER2327
#6148

Samedi 7 Tatane 139 (Saint Biribi, taulier - fête Suprême Quarte)
2 Thermidor An CCXX, 8,7319h - bouillon-blanc
2012-W29-5T20:57:24Z
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
203
Compte Supprimé 979
C
F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
139
Francky79
F
VBA_dev_Anne_Marie
  • Résolu(e)
Microsoft 365 VBA : somme par colonne
Réponses
9
Affichages
207
VBA_dev_Anne_Marie
VBA_dev_Anne_Marie
Regueiro
  • Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
280
sylvanu
sylvanu
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
92
Phil69970
Phil69970
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
223
florian50470
F
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
433
Phil69970
Phil69970
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
57
Latias
L
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
132
souhaib ad
S
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
1 K
saidoush
S

Membres actuellement en ligne

7 membres et 80 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 069
Messages
2 085 041
Membres
102 765
dernier inscrit
richdi