Aide pour alléger une macro

Signaler
Messages postés
17
Date d'inscription
mercredi 17 janvier 2007
Statut
Membre
Dernière intervention
16 juillet 2009
-
Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
-
Salut tout le monde,

Je vais peut être paraitre culotté mais j'espère que non....
En fait je suis débutant (du moins je l'étais vraiment il y a 1semaine mais j'ai un peu progressé du coup) et j'ai réalisé une petite macro.
Par contre vu que je débute j'ai pas du l'optimiser complétement parce que je la trouve particulièrement lente à s'executer.
Je voulais donc savoir si en vous la mettant en ligne vous pouviez jeter un coup d'oeil et corriger certaines conneries qui me bouffent un temps fou...

Merci d'avance à tous ceux qui se pencheront sur mon fichier pour me donner un coup de main

PS : je joinds 3 fichiers texte pour pouvoir faire 3imports. Au début du lancement de mon fichier excel on vous invite à dire combien vous voulez ouvrir de fichiers ( vous pouvez donc en ouvrir jusqu'à trois).

Vous allez trouver la macro pas si lente avec ces fichiers la parce qu'ils ne sont pas long. Les "vrais" fichiers feront plus de 2000lignes donc c'est beaucoup BEAUCOUP plus long..

Dernière info, avant de sortir du fichier il faut supprimer toutes les feuille et ne laisser qu'une seule feuille Nommée Feuil1 complétement vide

Le fichier : http://www.megaupload.com/?d=X1HMBFPV

5 réponses

Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
68
postes ici, c'est galère sans cela.

postes des points bloquants précis, au pire.

là, tu nous demande de faire ton boulot.........
Messages postés
17
Date d'inscription
mercredi 17 janvier 2007
Statut
Membre
Dernière intervention
16 juillet 2009

Pardo Renfield....

Je vais essayé de te faire une séléction de ce qui ralenti le plus (cela dit si les autres veulent bien regarder en global la macro ça serait top)

1) "Scann" de toutes les lignes pour retirer les doublons et ainsi ne garder qu'un exemplaire du titre de chaque sous chapitre

Sheets("Calcul").Select
    NouvNbreLignes = Application.CountA(Range("A1:A65536")) + 4
    Sheets("Calcul").Range(Cells(5, 3), Cells(NouvNbreLignes, 3)).Select
    Selection.Copy
    Sheets("Choix Chapitres").Select
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Cells(5, 2).Select
    ActiveCell.FormulaR1C1 = "=PROPER(RC[-1])"
    Selection.AutoFill Destination:=Range(Cells(5, 2), Cells(NouvNbreLignes, 2)), Type:=xlFillDefault
           
    Range(Cells(5, 2), Cells(NouvNbreLignes, 2)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft


    Range("A5").Select
    donnee1 = ActiveCell
    ActiveCell.Offset(1, 0).Select
    While ActiveCell <> ""
    If ActiveCell = donnee1 Then
 
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
Else
 donnee1 = ActiveCell
 ActiveCell.Offset(1, 0).Select
 End If


Wend

2) Création de CheckBox dans une colonne pour toutes les lignes (parfois il y a plus de 200lignes....)

Pour les x feuilles présentes dans l'analyse que souhaite faire l'utilisateur on se retrouve avec ca :

Sub InsertionCheckFeuilx()




    Dim x As Integer
    Dim i As Integer
  
   
'Boucle de 1 à Compteur, pour répéter l'opération sur toutes les feuilles concernées.
    For x = 1 To Compteur
    Worksheets(x).Select
    NbreLignes = Application.CountA(Range("E1:E65536")) + 3
    Range("T4").Select
    ActiveCell.FormulaR1C1 = "Pris en compte"
    With ActiveCell.Characters(Start:=1, Length:=14).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("T4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    Range(Cells(5, 20), Cells(NbreLignes, 20)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
          For i = 5 To NbreLignes
          Worksheets(x).Activate
          Cells(i, 20).Select
          t = ActiveCell.Top
          l = ActiveCell.Left
          Set obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
               DisplayAsIcon:=False, Left:=l + 30, Top:=t + 2, Width:=10, Height:=10 _
               )
        Next i
        NbreTaches = NbreLignes - 4
        For k = 1 To NbreTaches
        Worksheets(x).OLEObjects(k).Object.Value = True
        Next k
        Cells(5, 21).Select
        ActiveCell.FormulaR1C1 = "TRUE"
        Selection.AutoFill Destination:=Range("U5:U" & NbreLignes & ""), Type:=xlFillDefault
       
    ActiveSheet.Buttons.Add(1508.25, 20.25, 57.75, 15.75).Select
    Selection.OnAction = "Bouton2_QuandClic"
    Selection.Characters.Text = "Mise à jour"
    With Selection.Characters(Start:=1, Length:=11).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Columns("U:U").Select
    Selection.Font.ColorIndex = 2
      Next x
    
End Sub

Voila je pense que la se trouvent les 2principaux points noirs. Après le reste doit pas être trop méchant
Messages postés
1566
Date d'inscription
mardi 26 décembre 2000
Statut
Membre
Dernière intervention
5 avril 2013
6
Bonjour,

La plupart de tes select sont autant de sources de lenteurs !...
Réfère-toi directement aux plages, plutôt que de les sélectionner systémùatiquement en vue d'y travailler !
Messages postés
17
Date d'inscription
mercredi 17 janvier 2007
Statut
Membre
Dernière intervention
16 juillet 2009

Merci jmf0,
En fait j'ai procédé au nettoyage des select et j'y gagne un peu de temps mais les deux points les + compliqués (que je te recolle en dessous) et qui sont ceux qui bouffent le + de temps je n'arrive pas à les transformer.
C'est possible de faire un truc avec ca ?

          For i = 5 To NbreLignes
          Worksheets(x).Activate
          Cells(i, 20).Select
          t = ActiveCell.Top
          l = ActiveCell.Left
          Set obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
               DisplayAsIcon:=False, Left:=l + 30, Top:=t + 2, Width:=10, Height:=10 _
               )
        Next i


        NbreTaches = NbreLignes - 4
        For k = 1 To NbreTaches
        Worksheets(x).OLEObjects(k).Object.Value = True
        Next k

ET le deuxieme poits noir :


    Range("A5").Select
    donnee1 = ActiveCell
    ActiveCell.Offset(1, 0).Select
    While ActiveCell <> ""
    If ActiveCell = donnee1 Then
 
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
Else
 donnee1 = ActiveCell
 ActiveCell.Offset(1, 0).Select
 End If


Wend


 
Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
68
vire les .Select, les ActiveCell et autres gadgets visuels

par exemple:

Dim oCell As Range
Dim sFind As String
Set oCell = Cells(6, 1)
sFind = Cells(5, 1).Text
Do While LenB(oCell.Text)
If oCell.Text = sFind Then
Set oCell = oCell.Offset(1, 0)
oCell.Offset(-1, 0).EntireRow.Delete
Else
Set oCell = oCell.Offset(1, 0)
End If
Loop