Accelérer une macro

Le 30/04/2015 à 00:13

Bonjour à tous,

Je ne suis pas un pro avec VBA, et j'ai créé une macro assez longue (il me semble en tout cas)

L'exécution me parait assez lente, et j'aimerais voir si je peux faire autre chose pour l’accélérer (j'ai déjà changé pleins de trucs que j'avais fait à partir de "enregistrer une macro" pour l’accélérer)

Je vous la met ici :

Sub choisirdossieràimporter()

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "C:\Users\Jérôme\Desktop\RAPPORTS micros")
    If objFolder Is Nothing Then
        MsgBox "Abandon opérateur", vbCritical, "Annulation"
    Else

        Dossier = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
        Fichier = Dir(Dossier & "*.day")
        End If

     If Fichier > "" Then
         Else
        M$ = "Pas de fichier .asc dans le dossier " & Dossier & " !!"
    End If

    While Fichier > ""

ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Dossier & Fichier, Destination:=Range("A1"))
.Name = "fichier"
'importation du txt

        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(27, 8, 8, 15, 15, 16, 1, 8, 15, 15, 6)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    'mise en place des formules

    Range("C1") = "=SUMIF(C[-2],""24*"",C[0])"
    Range("D1") = "=SUMIF(C[-3],""310002 Sugg jour"",C[-1])"
    Range("E1") = "=SUMIF(C[-4],""25*"",C[-2])"
    Range("F1") = "=SUMIF(C[-5],""310001 Sugg sante"",C[-3])"
    Range("G1") = "=SUMIF(C[-6],""12*"",C[-4])"
    Range("H1") = "=SUMIF(C[-7],""310003 Sugg veget"",C[-5])"
    Range("I1") = "=SUMIF(C[-8],""26*"",C[-6])"
    Range("J1") = "=SUMIF(C[-9],""20*"",C[-7])"
    Range("K2") = "=SUMIF(C[-10],""17*"",C[-8])"
    Range("K3") = "=SUMIF(C[-10],""310007 Ame frite"",C[-8])"
    Range("K4") = "=SUMIF(C[-10],""310008 Froid frite"",C[-8])"
    Range("K1") = "=R[1]C+R[2]C+R[3]C"
    Range("L1") = "=SUMIF(C[-11],""*Grande crudite"",C[-9])"
    Range("M1") = "=SUMIF(C[-12],""*Petite crudite"",C[-10])"
    Range("N1") = "=SUMIF(C[-13],""40002 Potage"",C[-11])"
    Range("O1") = "=SUMIF(C[-14],""290060 Ravier legumes"",C[-12])"
    Range("P1") = "=SUMIF(C[-15],""900004 **PLATEAU**"",C[-13])"
    Range("Q1") = "=SUM(RC[-15]:RC[-7])"

    'copie juste des valeurs

    Rows("1:1").Copy
    Rows("2:2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    'copie de la date
    Range("I6").Copy
    Range("A2").Select
    ActiveSheet.Paste
    'changement format de la date
    Range("B2") = "=DATE(2000+VALUE(RIGHT(RC[-1],2)),MATCH(MID(RC[-1],3,3),Mois!R1C1:R12C1,0),VALUE(LEFT(RC[-1],2)))"
    'copie de la date sans reférence
    Range("B2").Copy
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3").Copy
    Range("B2").Select
    ActiveSheet.Paste

    Range("B2").Select
    Selection.NumberFormat = "dd/mm/yy;@"
    'mise en place du jour en fonction de la date

    Range("A2") = "=RC[1]"
    Range("A2").Select
    Selection.NumberFormat = "dddd"

    'ajout de l'entité en 1ère case
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B4").Copy
    Range("A2").Select
    ActiveSheet.Paste

    'Raccourci nom entités
    Range("A3") = "=IF(R[-1]C=""SABLON MIDI"",""SABMI"",R[-1]C)"
    Range("A3").Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3") = "=IF(R[-1]C=""GALILEE"",""GAL"",R[-1]C)"
    Range("A3").Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3") = "=IF(R[-1]C=""MARTIN V"",""MV"",R[-1]C)"
    Range("A3").Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3") = "=IF(R[-1]C=""SABLON SOIR SAM"",""SABSOIR"",R[-1]C)"
    Range("A3").Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'suppression lignes inutiles
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Rows("2:2").Select
    ActiveWindow.SmallScroll Down:=183
    Rows("2:500").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp

    'ajout no semaine

        Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1") = "=WEEKNUM(RC[2])"

    'centrer toutes les données

        Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    'mise en page des bordures
        Range("A1:S1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    'copie sur la feuille statistiques
    Rows("1:1").Select
    Selection.Copy
    Sheets("Statistiques Totales").Select
    Range("A1").Select
    Do While ActiveCell.Value > ""
    ActiveCell.Offset(1, 0).Select
    Loop

    ActiveSheet.Paste

    'suppression des feuilles

    Dim Compteur As Integer, Nom As String
    Application.DisplayAlerts = False
    For Compteur = Worksheets.Count To 1 Step -1
    Nom = Sheets(Compteur).Name
    Select Case Nom
    Case "Statistiques Totales", "Mois"

    Case Else
    Sheets(Compteur).Delete
    End Select
    Next Compteur
    Application.DisplayAlerts = True

    Fichier = Dir
    Wend

        'suppression des doublons
        Range("A1:S5000").Select
    ActiveSheet.Range("$A$1:$S$41").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _
        , 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19), Header:=xlYes

End Sub

Merci beaucoup !

Le 09/05/2015 à 22:34

Bonjour

une petite idée :

With Application
    .ScreenUpdating = False ' arrêt de la mise à jour de l'écran
    .EnableEvents = False ' arrêt de la surveillance événementielle
    .Calculation = xlManual ' arrêt des calculs
End With

' votre code

With Application
    .Calculation = xlAutomatic ' on remet les calculs automatiques
    .EnableEvents = True ' on remet la surveillance événementielle
    .ScreenUpdating = True ' on remet la mise à jour de l'écran
End With

La mise à jour de l'écran prend beaucoup de temps.

La surveillance événementielle peut en prendre beaucoup si vous faites des tests sur la modification de valeur de cellules par exemple.

Le calcul automatique est lancé à chaque modification de valeur de cellule, voir de sélection...

Déjà avec l'arrêt de ces trois composante, votre code devrait aller plus vite.

Si votre code modifie des valeurs de cellule, il faudra peut-être remettre le calcul avant l'impression afin d'avoir le résultat des calculs avec les nouvelles valeurs...

@ bientôt

LouReeD

Le 10/05/2015 à 23:13

Bonsoir,

en fait la macro avait le temps de "tourner" non ?

@ bientôt

LouReeD

Rechercher des sujets similaires à "accelerer macro"