Accélération d'une macros

Gérard -  
gbinforme Messages postés 14930 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

3 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      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
    2. 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
    3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      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
    4. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Pas de réponse: abandon du suivi sans regrets
      0
  2. gbinforme Messages postés 14930 Date d'inscription   Statut Contributeur Dernière intervention   4 744
     
    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
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      très sympa...
      0
    2. Gérard
       
      Merci à vous pour vos réponses, ça va beaucoup mieux grâce à vous.
      0
  3. gbinforme Messages postés 14930 Date d'inscription   Statut Contributeur Dernière intervention   4 744
     
    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

macros désactivées dans excel 2007
gillesdemev -
ANIS -

9 réponses
"macros complémentaires", où?
cg.c -
cg.c -

2 réponses
logiciel maintenance Denis Dalmont
moipatrickdubois -
NICOLASZAJAC -

12 réponses
ne retrouve plus mes macros
tmtm38 -
Utilisateur anonyme -

3 réponses
[EXCEL/VBA] Maintenance de macros
laurent1030 -
laurent1030 -

3 réponses