Accelerer un code

Bonjour à tous,

Mon soucis est le suivant:

J'ai ce bout de code qui me pose problème. En effet, lorsque je n'ai que 5 ligne à mon "activecell", le code tourne à une vitesse raisonnable mais dès que je rajoute la 6eme ligne, il tourne au ralenti ( et quand je dis au ralenti, c'est que pour me faire remonter 10 lignes donc 60 valeurs, celui-ci met près de 10 min contre 30s s'il n'y a que 5 lignes d'activecell....)

Aussi, je voudrait savoir si l'un d'entre vous aurais une idée pour résoudre mon pb.

voici le code en question:

Set ws = Sheets("saisie générale")
Set ws2 = Sheets("Filtre donnée analyse")

Dim I As Double
Dim lstrw As Long

lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row

For I = 3 To lstrw

If ComboBox12.Value = ws.Cells(I, 2).Value And ws.Cells(I, 8).Value >= CDate(Date) - ws1.Range("B" & 17) And ws.Cells(I, 8).Value <= CDate(Date) Then

ws2.Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

ActiveCell = ws.Cells(I, 5).Value '(mot)
ActiveCell.Offset(0, 1).Value = ws.Cells(I, 8).Value '(date)
ActiveCell.Offset(0, 2).Value = ws.Cells(I, 9).Value '(mot)
ActiveCell.Offset(0, 3).Value = ws.Cells(I, 10).Value '(nombre)
ActiveCell.Offset(0, 4).Value = ws.Cells(I, 11).Value '(nombre)
ActiveCell.Offset(0, 5).Value = ws.Cells(I, 4).Value '(valeur alphanumérique)

End If

Next

merci d'avance pour votre aide

jonathan

edit modo : placé code entre balises. Pensez à utiliser l'icone </> dans la barre de menu

Bonjour,

Ceci devrait aller (pas pu tester):

    Set ws = Sheets("saisie générale")
    Set ws2 = Sheets("Filtre donnée analyse")
    Dim I As Double
    Dim lstrw As Long, DerLig_ws2 as long
    Application.ScreenUpdating = False
    lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row
    For I = 3 To lstrw
        If ComboBox12.Value = ws.Cells(I, 2).Value And ws.Cells(I, 8).Value >= CDate(Date) - ws1.Range("B" & 17) And ws.Cells(I, 8).Value <= CDate(Date) Then
            DerLig_ws2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
            Range(ws2.Cells(DerLig_ws2, "A"), ws2.Cells(DerLig_ws2, "F")).Value = Array(ws.Cells(I, 5), ws.Cells(I, 8), ws.Cells(I, 9), ws.Cells(I, 10), ws.Cells(I, 11), ws.Cells(I, 12))
        End If
    Next

Cdlt

bonjour Arturo83, jonanse54122,

Même remarque Arturo83, comme on n'a pas eu un fichier, ceci n'est pas testé, mais j'ai ajouté un filtre à l'idée d'Arturo83.

Il y a 2 choses à éviter dans votre macro, c'est "Select", cela ne sert à rien et ralentit tout et minimaliser les fois d'écrire quelque chose. Dans votre exemple, c'est 5 fois par ligne, avec la code d'Arturo83, 1 fois par ligne, on peut encore faire mieux, si on veut, en 2 fois, la plage de la colonne 5 et la plage des colonnes 8 à 12. Si vous ajoutez un exemple, on peut tester le gain de temps de cela.

Sub test()

     Dim c, ws, ws2, t
     t = Timer
     Application.ScreenUpdating = False

     Set ws = Sheets("saisie générale")
     Set ws2 = Sheets("Filtre donnée analyse")
     lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row

     If ws.AutoFilterMode Then ws.AutoFilterMode = False 'supprimer autofilter existante, si présent
     With ws.Range("A2").Resize(lstrw - 1, 8) 'cette plage
          .AutoFilter 2, combobox12.Value
          .AutoFilter 8, ">=" & Format(Date - ws1.Range("B" & 17).Value, "mm/dd/yyyy"), xlAnd, "<=" & Format(Date, "mm/dd/yyyy")
          For Each c In .Columns(1).SpecialCells(xlVisible)
               If c.Row <> .Row Then
                    ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 6).Value = Array(ws.Cells(I, 5), ws.Cells(I, 8), ws.Cells(I, 9), ws.Cells(I, 10), ws.Cells(I, 11), ws.Cells(I, 12))
               End If
          Next
          .AutoFilter
     End With
     MsgBox "prêt en " & Format(Timer - t, "0.00\s")
End Sub

Bonjour à tous,
Je passais par là !...
Bonne journée.

Sub test()
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lastRow As Long, lRow As Long
Dim r As Range
Dim arr(5) As Variant

    Set ws = WorkSheets("saisie générale")
    Set ws2 = WorkSheets("à définir")
    Set ws3 = WorkSheets("Filtre donnée analyse")

    lastRow = ws.Cells(Rows.Count, 6).End(xlUp).Row
    Set r = ws3.Cells(ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

    For lRow = 3 To lastRow
        If ComboBox12.Value = ws.Cells(lRow, 2).Value And ws.Cells(lRow, 8).Value >= CDate(Date) - ws2.Cells(14, 2).Value And ws.Cells(lRow, 8).Value <= CDate(Date) Then
            With ws
                arr(0) = .Cells(lRow, 5).Value      '(mot)
                arr(1) = .Cells(lRow, 8).Value      '(date)
                arr(2) = .Cells(lRow, 9).Value      '(mot)
                arr(3) = .Cells(lRow, 10).Value     '(nombre)
                arr(4) = .Cells(lRow, 11).Value     '(nombre)
                arr(5) = .Cells(lRow, 4).Value      '(valeur alphanumérique)
                r.Resize(, 6).Value = Application.tranpose(arr)
                Set r = r.Offset(1)
            End With
        End If
    Next
End Sub

Bonjour à tous.

Merci pour vos explications et vos suggestions.

Après avoir passer un moment à essayer de faire tourner vos différents codes, j'ai jeter mon dévolu sur celui de Bart qui m'est plus accessible à savoir:

Dim lstrw As Long

Application.ScreenUpdating = False
lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row
If ws.AutoFilterMode Then ws.AutoFilterMode = False
With ws.Range("A2").Resize(lstrw - 1, 8)
.AutoFilter 2, ComboBox12.Value
.AutoFilter 8, ">=" & Format(Date - ws1.Range("B" & 17).Value, "mm/dd/yyyy"), xlAnd, "<=" & Format(Date, "mm/dd/yyyy")
For Each c In ws.Columns(1).SpecialCells(xlVisible)
If c.Row <> .Row Then
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 6).Value = Array(ws.Cells(i, 5), ws.Cells(i, 8).Value, ws.Cells(i, 9), ws.Cells(i, 10), ws.Cells(i, 11), ws.Cells(i, 4))
End If
Next
.AutoFilter
End With

j'ai cependant un soucis d'erreur qui remonte; il me dit "erreur défini par l'application ou par l'objet" sur la ligne

ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 6).Value = Array(ws.Cells(i, 5), ws.Cells(i, 8).Value, ws.Cells(i, 9), ws.Cells(i, 10), ws.Cells(i, 11), ws.Cells(i, 4))

J'ai essayer de remplacer la variable "I" par "c" car dans "For Each c In ws.Columns(1).SpecialCells(xlVisible)" , vous avez utiliser "c" mais rien y fait...

auriez vous des éclaircissements à m'apporter?

Pour ce qui est du fichier pour le tester, je sais que c'est plus simple si je vous le fait parvenir cependant l'ensemble des données qu'il contient est "sensible"donc je ne peut pas vous l'envoyer en l'état

Cdl

Jonathan

Bonjour,

A la place de "C", mettez "C.row" , exemple; ws.Cells(c.row, 5)

Cdlt

Merci, c'était bien ça.

cependant, maintenant dès que je lance la macro, ça mouline sans s’arrêter et je suis obliger de faire un fin de tache a excel pour l’arrêter.

si vous avez des suggestions, je suis preneur :-)

jonathan

Je ne voudrai pas intervenir dans le code de BsAlv que je salue? Patientez le temps qu'il prenne connaissance du problème, à moins qu'il soit en congé, dans ce cas on pourra regarder.

Mais comme spécifier plus haut, sans fichier mis à disposition, il n'est pas évident de corriger un problème.

En attendant, je vous conseillerai de faire tourner votre code en pas à pas (c'est ce que nous ferions), et là, vous devriez voir où ça coince.

👍

bonjour le fil et salut ARturo83 et sorry pour vous garder en attente.

ici dessus vous voyez une construction d'un "With .... End With", quelque chose vraiment utile pour structurer la macro, il ne faut plus répéter les choses quand quelque chose commence avec un point comme la 2ième ligne jaune. Comme ce ".Columns(1).SpecialCells(xlVisible)" commence avec un point, il faut chercher le "with" précédent et ajouter ce qui suit avant le point, donc le with précédent, c'est With ws.Range("A2").Resize(lstrw - 1, 8) et donc excel lit cela comme 
For Each c In ws.Range("A2").Resize(lstrw - 1, 8).Columns(1).SpecialCells(xlVisible)
= chaque cellule visible de la première colonne de la plage qui commence avec A2 de ws avec "lstrw-1" lignes et 8 colonnes.
Supposons que lstrw = 100 et qu'il y a 20 cellules visible (inclu la ligne 2 = l'entête), alors la macro passera par 20 cellules. Cela sera bientôt fait

C'est quelque chose différent avec votre macro avec un ws en face du point
For Each c In ws.Columns(1).SpecialCells(xlVisible)
= chaque cellule visible de la première colonne de la feuille ws
Dans notre exemple précédent avec 100 lignes dont 20 visibles, cette lignes veut dire toutes les lignes de la feuille (=1.048.576) moins les lignes invisible (=100-20=80) = environ 1.048.500 lignes à passer et cela prend du temps <ej data-image="1f644" style="background:url(https://forum.excel-pratique.com/template/img/emojis/1f644.svg)"></ej>

Donc, conclusion, supprimez ce ws en face et lisez ce lien https://indexmatch.fr/le-bloc-vba-with-end-with

bonjour a vous.

merci pour ce petit cour fort sympathique.

tu explique vraiment bien 👍

ca y est, ça fonctionne nickel.

un grand merci !!!

Bonjour

Quand on met à jour des données dans les cellules Excel, il y a deux méthodes à appliquer systématiquement pour gagner (beaucoup) de temps :

Au début de la boucle

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Et en fin de procédure ou à minima de la boucle

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ScreenUpdating fige l'écran et Calculation arrête le calcul automatique.

Sinon ''ws2.Activate'' est très lent dans une boucle, le code VBA peut lire et écrire dans une cellule sans activer le classeur la feuille et une cellule

        ws2.Activate
        Range("A1").Select
        Selection.End(xlDown).Select
        Selection.Offset(1, 0).Select

En résumé les lignes ci-dessus ralentissent considérablement l'exécution du code. Tes 4 lignes de codes servent à déterminer la dernière ligne de la feuille, tu peux les remplacer par une des 3 solutions :

    Dim rCell2 As Range
    Set rCell2 = ws2.Range("A1").End(xlDown).Offset(1) ' Méthode 1
    Set rCell2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1) ' Méthode 2
    Set rCell2 = ws2.Cells(ws2.UsedRange.Rows.Count + 1, "A").Offset(1) ' Méthode 3

La première méthode est moins fiable que la seconde, car il ne faut pas de cellule vide en colonne A

La seconde est très bien mais sensible au filtre car si des données sont filtrées, il peut renvoyer un résultat erroné, la dernière pouvant être masquée.

La troisième est celle que j'utilise quasiment toujours, mais elle de foncionne très bien quand on est sur des feuilles non manipulées manuellement, car cette méthode s'appuie sur la plage active (UsedRange). La plage active peut être disproportionnée quand une personne fait une modification dans une ligne trop lointaine, que ce soit la valeur ou un format. On le voit très bien quand l'ascenceur vertical sort de la plage active quand on le descend au plus bas.

Ensuite tu peux mettre à jour ta nouvelle ligne

        With rCell2
            .Offset(0, 1).Value = ws.Cells(I, 8).Value '(date)
            .Offset(0, 2).Value = ws.Cells(I, 9).Value '(mot)
            .Offset(0, 3).Value = ws.Cells(I, 10).Value '(nombre)
            .Offset(0, 4).Value = ws.Cells(I, 11).Value '(nombre)
            .Offset(0, 5).Value = ws.Cells(I, 4).Value  '(valeur alphanumérique)
        End With

La solution la plus radicale et efficace sur un gros volume de données (lignes et colonnes), c'est de mettre les feuilles en tables mémoire, d'exécuter le programme puis de restituer le résultat par ligne ou par duplication d'une feuille entière, mais je ne vais pas mettre un exemple, il semble que tu aies résolu ton problème de performances.

Benead

Bonjour Jean-Eric,

Bien que mon problème soit résolu, je me suis "re"pencher sur la proposition de code que tu m'a fourni.

Je cherche tout de même à comprendre ce que tu as marqué dans l'idée ou cela me servirai à l'occasion.

j'avoue rester bloquer sur le fait que tu déclare seulement arr(5) comme un variant mais tu utilise arr(0), arr(1), etc jusqu'à arr(5) et du coup, je suis perdu.

De plus, je souhaiterai savoir a quoi sert la ligne suivante?

 r.Resize(, 6).Value = Application.tranpose(arr)

Merci d'avance pour ton retour.

Cordialement.

Jonathan

Bonjour,

Je réponds à la place de Jean-Eric, car tu attends la réponse depuis une semaine :

On déclare le tableau (Array) nommé arr qui contiendra 6 valeurs, par défaut de 0 à 5, c'est un tableau d'une seule dimension

Dim arr(5) As Variant

Tu peux aussi le déclarer en partant de 1 ;

Dim arr(1 To 6) As Variant

Les tableaux sont chargés en mémoire, ils accélèrent donc considérablement les temps de traitement des programmes.

Ensuite on charge chaque élément du tableau :

                arr(0) = .Cells(lRow, 5).Value      '(mot)
                arr(1) = .Cells(lRow, 8).Value      '(date)
                arr(2) = .Cells(lRow, 9).Value      '(mot)
                arr(3) = .Cells(lRow, 10).Value     '(nombre)
                arr(4) = .Cells(lRow, 11).Value     '(nombre)
                arr(5) = .Cells(lRow, 4).Value      '(valeur alphanumérique)

Donc de 0 à 5 dans ton cas.

Enfin on restitue le tableau sur la feuille Excel dans les 6 cellules réceptrices, c'est à dire qu'on copie le tableau dans les cellules :

                r.Resize(, 6).Value = Application.tranpose(arr)

Il y a un "Application.Transpose", car quand il y a une seule dimension, on colle dans une seule colonne, la fonction transpose permet de coller dans une ligne.

Quand on colle un tableau dans une feuille, la dimmension de la plage doit être identique à celle du tableau, d'où l'utilisation de Resize(,6) qui agrandit la plage à 6 cellules.

Benead

re,

l'idéal est de lire tout en mémoire (=tableau), traiter et écrire le résultat vers votre feuille, par exemple par ceci (c'est en lisant et écrivant qu'on pert du temps, mais on ne fait pas cela pour seulement 10 lignes). J'éspère qu'il n'y a pas de fautes dans cette code, je ne l'ai pas testé parce que je n'avais pas de données ...

Sub test()

     Dim c, ws, ws2, t, aA, c, N, Lignes, Colonnes
     t = Timer
     Application.ScreenUpdating = False

     Set ws = Sheets("saisie générale")
     Set ws2 = Sheets("Filtre donnée analyse")
     lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row

     If ws.AutoFilterMode Then ws.AutoFilterMode = False     'supprimer autofilter existante, si présent
     With ws.Range("A2").Resize(lstrw - 1, 12)     'cette plage
          .AutoFilter 2, combobox12.Value
          .AutoFilter 8, ">=" & Format(Date - ws1.Range("B" & 17).Value, "mm/dd/yyyy"), xlAnd, "<=" & Format(Date, "mm/dd/yyyy")

          N = .Columns(1).SpecialCells(xlVisible).Count     'nombre de lignes visible (incl. entête)
          If N > 1 Then
               Set c = .Offset(.Rows.Count + 10).Resize(N)     'plage auxiliaire en dessous vos données
               .Offset(1).SpecialCells(xlVisible).Copy     'copier sauf entête
               c.PasteSpecial xlValues       'coller ici
               aA = c.Resize(N - 1).Value2   'lire contenu dans tableau
               c.ClearContents               'RAZ plage auxiliaire

               Lignes = Evaluate("row(A1:A" & UBound(aA) & ")")     'tableau avec toutes les lignes
               Colonnes = Array(5, 8, 9, 10, 11, 12)     'tableau avec les colonnes intéressantes
               ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(N - 1, UBound(Colonnes) + 1).Value = Application.Index(aA, Lignes, Colonnes)
          End If
          .AutoFilter
     End With
     MsgBox "prêt en " & Format(Timer - t, "0.00\s")
End Sub

Merci pour les explications Benead :)

Sinon BsAlv, j'ai tester ton nouveau code et en effet, c'est encore plus rapide :)

Ca l'est tellement que les données importées n'ont pas le temps d'être analysées par les graphiques de la feuille de calcul que j'essaye d'afficher... car à la suite du code que tu m'a sorti, j'ai ceci

Set g = Sheets("Filtre donnée analyse").ChartObjects(1).Chart
fichier = ActiveWorkbook.Path & "\" & "graphe.gif"
g.Export Filename:=fichier, FilterName:="GIF"
Image1.Picture = LoadPicture(fichier)
Kill fichier
Set F = Sheets("Filtre donnée analyse").ChartObjects(2).Chart
fichier = ActiveWorkbook.Path & "\" & "graphe2.gif"
F.Export Filename:=fichier, FilterName:="GIF"
Image2.Picture = LoadPicture(fichier)
Kill fichier

If nb_mois.Value >= 12 Then
Set H = Sheets("Filtre donnée analyse").ChartObjects(3).Chart
fichier = ActiveWorkbook.Path & "\" & "graphe3.gif"
H.Export Filename:=fichier, FilterName:="GIF"
Image3.Picture = LoadPicture(fichier)
Kill fichier
End If

Or, j'obtiens ceci

Pour que les graphique soit avec de belles courbes et camembert sur la feuille de donnée comme ci dessous, il faut que je quitte la userform, que j'aille dans la feuille de calcul et que j'attendent quelques centieme de seconde pour que les cellules s'actualisent et que j'obtienne ca

une idée pour importer les graphiques qu'apres que la feuille de calcul est pris en compte l'ensemble des modifications de ses cellules(ici environs 400 lignes soit sur 6 colonnes à peut près 2400 cellules)

re,

vous pouvez ajouter une macro paramètrée "Attendre" et utilisez celui comme ceci (attendre un tout petit moment à des points critiques de votre macro.

 Sub Attendre(Optional Msec As Integer)
     Dim T, T1, T2
     If Msec = 0 Then Msec = 100             'si on dit rien, c'est 100 msec
     t0 = Timer
     T1 = Timer + Application.Max(50, Application.Min(Msec, 1000)) / 1000
     b = (T1 > 86400)
     Do
          DoEvents
          T = Timer - b * 86400
     Loop While (t0 <= T Or b) And T < T1
End Sub

 Set g = Sheets("Filtre donnée analyse").ChartObjects(1).Chart
     fichier = ActiveWorkbook.Path & "\" & "graphe.gif"
     g.Export Filename:=fichier, FilterName:="GIF"
     Attendre 250   '<<<<<<<<<< ICI attendre 250 millisecondes
     Image1.Picture = LoadPicture(fichier)
     Kill fichier

Merci, avec cette fonction, c'est mieux.

Du coup comme tout fonctionne bien plus vite qu'avant j'ai tester de mettre un filtre de date plus grand ( je me limitait à 3 mois avant et la, j'ai essayer 6) mais dans ce cas de figure, excel m'annonce que la ligne

ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(N - 1, UBound(Colonnes) + 1).Value = Application.Index(aA, Lignes, Colonnes)

présente un défaut d'incompatibilité de type...

Y-a-t-il un nombre de ligne limite au tableau? car en faisant ce type de filtre, je pense qu'on monterait sur quelque chose comme 500-600 lignes contre 350 sur 3 mois.

re,

c'est difficile à dire sans fichier, vous avez un exemple ? Les limites sont plutôt +16.000 ou +32.000 lignes

Si on le fait en 2 lignes, l"erreur se passe où ?

aa2 = Application.Index(aA, Lignes, Colonnes)
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(aa2), UBound(aa2, 2)).Value = aa2

oubien

Sub test()

     Dim c, ws, ws2, t, aA, c, N, Lignes, Colonnes
     t = Timer
     Application.ScreenUpdating = False

     Set ws = Sheets("saisie générale")
     Set ws2 = Sheets("Filtre donnée analyse")
     lstrw = ws.Cells(Rows.Count, 6).End(xlUp).Row

     If ws.AutoFilterMode Then ws.AutoFilterMode = False     'supprimer autofilter existante, si présent
     With ws.Range("A2").Resize(lstrw - 1, 12)     'cette plage
          .AutoFilter 2, combobox12.Value
          .AutoFilter 8, ">=" & Format(Date - ws1.Range("B" & 17).Value, "mm/dd/yyyy"), xlAnd, "<=" & Format(Date, "mm/dd/yyyy")

          N = .Columns(1).SpecialCells(xlVisible).Count     'nombre de lignes visible (incl. entête)
          If N > 1 Then
               Set c = .Offset(.Rows.Count + 10).Resize(N)     'plage auxiliaire en dessous vos données
               .Offset(1).SpecialCells(xlVisible).Copy     'copier sauf entête
               c.PasteSpecial xlValues       'coller ici, temporairement

               Set c2 = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)     'plage destination "analyse"
               Colonnes = Array(5, 8, 9, 10, 11, 12)     'tableau avec les colonnes intéressantes, attention ce tableau commence avec index 0 !!!
               For j = 0 To UBound(Colonnes)
                    c.Cells(1, j + 1).Resize(N - 1).Copy     'copier une colonne à la fois
                    c2.Cells(1, j + 1).PasteSpecial xlValues
               Next

               c.ClearContents               'RAZ plage auxiliaire
          End If
          .AutoFilter
     End With
     MsgBox "prêt en " & Format(Timer - t, "0.00\s")
End Sub

re,

Le fait de doubler le nombre de ligne avec

aa2 = Application.Index(aA, Lignes, Colonnes)
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(aa2), UBound(aa2, 2)).Value = aa2

n'a aucun effet malheureusement.

Pour ce qui est du nouveau code que tu m'a fournis ci-dessus, les colonnes copiées/collées ne sont pas les colonnes 5,8,9,10,11 et 12 mais 1,2,3,4,5 et 6 et ce malgré le colonne=array...

Sinon pour ce qui est de retirer le Resize(N-1) dans cette ligne,

aA = c.Resize(N - 1).Value2 'lire contenu dans tableau,

ca n'enlève rien au problème de le retirer...

Désolé pour ce casse tête.... mais merci pour ta patience et persévérance...