Accélération d'une macros

Gérard -  
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour, j'aimerais savoir si quelqu'un peu m'indiquer pourquoi ma macros prend une heure à se compléter (308 000 lignes). Y a-t-il un moyen de la modifier pour cela? 

Sub pre_traitement_donnees()
Application.ScreenUpdating = False

    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=0,2400,RC[-1])"
    Range("D1").Select
    Selection.AutoFill Destination:=Range("D:D")

    Range("D:D").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    
    Sheets("Base").Select

 
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Feuil1").Select
    Sheets("Feuil1").Name = "102"
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Feuil2").Select
    Sheets("Feuil2").Name = "115"
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Feuil3").Name = "140"
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Feuil4").Name = "160"
   

Sheets("Base").Select

  Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
    If Range("A" & i).Value = "102" Then Rows(i).Copy Destination:=Sheets("102").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
For i = 2 To LR
    If Range("A" & i).Value = "115" Then Rows(i).Copy Destination:=Sheets("115").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
For i = 2 To LR
    If Range("A" & i).Value = "140" Then Rows(i).Copy Destination:=Sheets("140").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i

For i = 2 To LR
    If Range("A" & i).Value = "160" Then Rows(i).Copy Destination:=Sheets("160").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End Sub
A voir également:

3 réponses

Réponse 1 / 3
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
Bonjour,

Effectivement, à part le screenupdating, il y a tout pour ralentir la procédure; select-selection, copy-paste....

Pour être concret car il y a rien de + risqué de modifier un code sans le tester,

mettre UN EXTRAIT (3000 lignes maxi) du classeur sans données confidentielles en pièce jointe sur
https://www.cjoint.com/
puis copier l'adresse du lien et la coller dans le message de réponse

Dans cette attente
0
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
En attendant "le" classeur

combien de colonnes maxi dans la feuilles "base" ?

macro partielle jusqu'à la construction de nouvelles feuilles 

Option Explicit
Sub pretraitement_ccm()
Dim Derlig As Long, Col_c(), Cptr As Long

Application.ScreenUpdating = False

'------- -------Traitement colonne_C
With ActiveSheet
     Derlig = .Range("C" & Rows.Count).End(xlUp).Row
     'mémorisation colonne C en RAM
     Col_c = Application.Transpose(.Range("C1:C" & Derlig).Value)
     For Cptr = 1 To UBound(Col_c)
          Col_c(Cptr) = IIf(Col_c(Cptr) = 0, 2400, Col_c(Cptr))
     Next
     'restitution calculée
     .Range("C1").Resize(UBound(Col_c), 1) = Application.Transpose(Col_c)
End With

'-------------Ajout 4 feuilles
ajouter_feuille 102
ajouter_feuille 115
ajouter_feuille 140
ajouter_feuille 160

End Sub

'######################
Sub ajouter_feuille(onglet)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = onglet
End Sub


Si pas de signe de vie jusqu'à samedi midi, abandon du suivi
0
Gérard
 
Bonjour, merci de la réponse. En réalité, la partie qui pose problème est la fin, soit :
Sheets("Base").Select

Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
If Range("A" & i).Value = "102" Then Rows(i).Copy Destination:=Sheets("102").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
For i = 2 To LR
If Range("A" & i).Value = "115" Then Rows(i).Copy Destination:=Sheets("115").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
For i = 2 To LR
If Range("A" & i).Value = "140" Then Rows(i).Copy Destination:=Sheets("140").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i

For i = 2 To LR
If Range("A" & i).Value = "160" Then Rows(i).Copy Destination:=Sheets("160").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End Sub

le reste s'exécute en une fraction de seconde. L'objectif est de séparer les lignes selon le code qui leur est attribué dans la colonne A, soit 102, 115, 140 ou 160 et de les coller sur la feuille précédemment créée et qui possède le même code.

Désolé pour la réponse tardive, nous ne sommes vraiment pas sur le même fuseau horaire (Québec).
0
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
Bonjour,
Désolé pour la réponse tardive, nous ne sommes vraiment pas sur le même fuseau horaire (Québec).
D'accord c'est noté

pour la 2° partie, je ne l'avais pas encore attaquée, notamment en attente des réponses à mes demandes; et de m^me je me demande pourquoi tu as fait un copier-coller de ton 1° envoi: peut-être que je ne sais pas lire

le reste s'exécute en une fraction de seconde. Merci, très sympa de ta part: garde ta macro , je me suis cassé la t^te pour me faire envoyer paitre :-((

. L'objectif est de séparer les lignes selon le code qui leur est attribué dans la colonne A, soit 102, 115, 140 ou 160 et de les coller sur la feuille précédemment créée et qui possède le même code.
Merci, j'avais compris sinon je t'aurais demandé des explications


d'autre part je t'avais fait des demandes auxquelles tu n'as pas répondu:

1° lien 17/1 8:34
mettre UN EXTRAIT (3000 lignes maxi) du classeur sans données confidentielles en pièce jointe sur
https://www.cjoint.com/
puis copier l'adresse du lien et la coller dans le message de réponse

2° lien 17/1 12:22
combien de colonnes maxi dans la feuilles "base" ?


Et pendant que j'y suis:
la colonne A de la feuille "base" ne comporte t' elle que les 4 numéros 102, 115, 140, 160 ?

Libre à toi de me répondre, j'attends donc que tu daignes le faire
0
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
Pas de réponse: abandon du suivi sans regrets
0
Réponse 2 / 3
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   4 727
 
Bonjour Gérard, Michel,

Comme le soleil s'est un peu mis en grève autant profiter de l'écran. ;-)
J'ai donc regardé ce que tu voulais faire avec ta macro et je te propose ce code. 
Sub speed_pre_traitement_donnees()
Dim col As Integer, LR As Long, f As Integer, deb As Date
Dim nom(), tbd(), tbf(), n As Integer, idd As Long, idf As Long
    nom = Array(102, 115, 140, 160)     ' table sélection
    deb = Time
    Application.ScreenUpdating = False
    With Sheets("Base")
        col = .UsedRange.Columns.Count  ' nombre colones
        LR = .UsedRange.Rows.Count      ' nombre lignes
        tbd = .Cells(1, 1).Resize(LR, col).Value    ' base en table
        For n = 0 To 3                  ' ventilation sur feuilles
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = nom(n)   ' nouvelle feuille
            idf = 1
            ReDim tbf(1 To UBound(tbd), 1 To col)
            For f = 1 To col            ' copie titre
                tbf(idf, f) = tbd(1, f)
            Next f
            For idd = 1 To UBound(tbd)  ' copie données
                If tbd(idd, 3) = 0 Then tbd(idd, 3) = 2400
                If tbd(idd, 1) = nom(n) Then
                    idf = idf + 1
                    For f = 1 To col    ' ligne sélectionnée
                        tbf(idf, f) = tbd(idd, f)
                    Next f
                End If
            Next idd                    ' table sur feuille
            Cells(1, 1).Resize(UBound(tbf, 1), UBound(tbf, 2)).Value = tbf
        Next n                          ' table base sur feuille
        .Cells(1, 1).Resize(UBound(tbd, 1), UBound(tbd, 2)).Value = tbd
    End With
    MsgBox "Début_: " & deb & vbLf & "Fin____: " & Time
    Sheets("Base").Activate
    Application.ScreenUpdating = True
End Sub

Pour traiter rapidement ce type de procédure, il vaut mieux éviter de fonctionner sur les feuilles car les adressages sont gourmands en calculs. La macro te fourni le temps d'exécution qui devrait descendre sous la minute.

Bon test
0
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
très sympa...
0
Gérard
 
Merci à vous pour vos réponses, ça va beaucoup mieux grâce à vous.
0
Réponse 3 / 3
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   4 727
 
Bonjour,

Cyrano de Bergerac : Ah ! non ! c'est un peu court, jeune homme !
On pouvait dire... Oh ! Dieu !... bien des choses en somme.

Pour tous ceux qui vont lire ce poste tu aurais pu "dire... bien des choses" afin que l'on puisse comprendre en quoi nos réponses t'ont aidé ou perturbé, si ton souci de durée c'était amélioré et comment, etc ...
Merci de le faire pour donner une solution à ta question.
0

Discussions similaires

Accélération GPU
Thomaso -
maynemiz -

1 réponse
Cet effet requiert une accélération gpu-Premiere pro 2019
Olihustler -
fermiparadoxx -

9 réponses
Cet effet requiert une accélération GPU sur mac
TO -
To -

2 réponses
Macro sur smartphone Android
MichyNsr -
MichyNsr -

2 réponses
accélération GPU désactivé
zero_en_info -
baladur13 -

4 réponses