Aide pour alléger une macro

Question

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

Renfield · Answer

postes ici, c'est galère sans cela.

postes des points bloquants précis, au pire.

là, tu nous demande de faire ton boulot.........

grosboufLG · Answer

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

jmf0 · Answer

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 !

grosboufLG · Answer

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

Renfield · Answer

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

Aide pour alléger une macro

5 réponses

Votre réponse

Discussions similaires