Macro exécution trop longue

Zack -
Zack - 21 août 2015 à 15:42

Bonjour j'ai réalisé une macro sur excel mais le temps d'exécution est vraiment trop long (environ 10min). Je ne vois pas quoi faire pour améliorer mon code, je suis un peu limité dans ce domaine. Du coup je mets mon code et si qqun a du temps pour jeter un oeil et peut etre m'indiquer une astuce je le remercie grandement!

Ci-dessous mon code

Sub Recuperer_donnees()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wbc As Workbook
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim NomFichier As String
Dim nomfich As String
Dim J As Integer
Dim M As Integer
Dim A As Integer
Dim i As Integer
Dim k As Integer
Dim x As Integer
Dim y As Integer
Dim Fich As String, Texte As String
Dim myPath As String, myFile As String

'définition et "nettoyage" du fichier de calcul
Set wbc = Workbooks("Fichier Calcul - potiche")
    Sheets("Ond1").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
      
    Sheets("Ond2").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
      
    Sheets("Ond3").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    
'Récupération du mois et de l'année de calcul
    M = Month(CDate(Sheets("Synthèse").Range("C1")))
    A = Sheets("Synthèse").Range("Z1").Value

'Nom fichier de données brutes
    myPath = ThisWorkbook.Path
    
'    myFile = Dir(myPath & "\*.xls*")
'    chemin = myPath & "\Données_brutes\" & A & "-" & M & "\"
'    Fich = Dir(chemin & "*.csv")
'    i = 1
'    Do While Fich <> ""
'        If Fich <> "Test" Then
'            Texte = i & ".csv"
'            Name chemin & Fich As chemin & Texte
'        End If
'        i = i + 1
'        Fich = Dir()
'    Loop

'Définition du chemin d'accès pour le premier jour du mois et ouverture du fichier
    nomfich = myPath & "\Données_brutes\" & A & "-" & M & "\" & "1.csv"
    Set wb1 = Workbooks.Open(nomfich, Format:=5)
   
'Copier coller des données du premier jour du mois et fermeture du fichier
    wb1.Activate
    Range("A8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    wbc.Activate
    Sheets("Ond1").Select
    Range("D1").Select
    ActiveSheet.Paste
    
    wb1.Activate
    i = 8
    While Cells(i, 1).Value <> " Début Process CONV2 "
    i = i + 1
    Wend
    Cells(i + 2, 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    wbc.Activate
    Sheets("Ond2").Select
    Range("D1").Select
    ActiveSheet.Paste
    
    wb1.Activate
    k = 8
    While Cells(k, 1).Value <> " Début Process CONV3 "
    k = k + 1
    Wend
    Cells(k + 2, 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    wbc.Activate
    Sheets("Ond3").Select
    Range("D1").Select
    ActiveSheet.Paste
    wb1.Close
    
'Copie des données pour janvier, mars, mai, juillet et aout
If M = 1 Or M = 3 Or M = 5 Or M = 7 Or M = 8 Or M = 10 Or M = 12 Then
    For J = 2 To 31
        If Dir(myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv") <> "" Then
            NomFichier = myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv"
            
            Set wb2 = Workbooks.Open(NomFichier, Format:=5)
            wb2.Activate
            Range("A9").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond1").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
                
            wb2.Activate
            x = 8
            While Cells(x, 1).Value <> " Début Process CONV2 "
            x = x + 1
            Wend
            Cells(x + 3, 1).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond2").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
            
            wb2.Activate
            y = 8
            While Cells(y, 1).Value <> " Début Process CONV3 "
            y = y + 1
            Wend
            Cells(y + 3, 1).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond3").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
            wb2.Close
        End If
    Next J
End If

'Copie des données pour avril, juin et septembre
If M = 4 Or M = 6 Or M = 9 Or M = 11 Then
    For J = 2 To 30
        If Dir(myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv") <> "" Then
            NomFichier = myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv"
            
            Set wb2 = Workbooks.Open(NomFichier, Format:=5)
            wb2.Activate
            Range("A9").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond1").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
            
            wb2.Activate
            x = 8
            While Cells(x, 1).Value <> " Début Process CONV2 "
            x = x + 1
            Wend
            Cells(x + 3, 1).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond2").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
    
            wb2.Activate
            y = 8
            While Cells(y, 1).Value <> " Début Process CONV3 "
            y = y + 1
            Wend
            Cells(y + 3, 1).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            wbc.Activate
            Sheets("Ond3").Select
            Range("D2").Select
            Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
            ActiveSheet.Paste
            wb2.Close
        End If
    Next J
End If

'Copie des données pour février
If A Mod 4 <> 0 Then
    If M = 2 Then
        For J = 2 To 28
            If Dir(myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv") Then
                NomFichier = myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv"
                    
                Set wb2 = Workbooks.Open(NomFichier, Format:=5)
                wb2.Activate
                Range("A9").Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond1").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
            
                wb2.Activate
                x = 8
                While Cells(x, 1).Value <> " Début Process CONV2 "
                x = x + 1
                Wend
                Cells(x + 3, 1).Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond2").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
    
                wb2.Activate
                y = 8
                While Cells(y, 1).Value <> " Début Process CONV3 "
                y = y + 1
                Wend
                Cells(y + 3, 1).Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond3").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
                wb2.Close
            End If
        Next J
    End If
Else
    If M = 2 Then
        For J = 2 To 28
            If Dir(myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv") Then
                NomFichier = myPath & "\Données_brutes\" & A & "-" & M & "\" & J & ".csv"
                    
                Set wb2 = Workbooks.Open(NomFichier, Format:=5)
                wb2.Activate
                Range("A9").Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond1").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
            
                wb2.Activate
                x = 8
                While Cells(x, 1).Value <> " Début Process CONV2 "
                x = x + 1
                Wend
                Cells(x + 3, 1).Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond2").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
    
                wb2.Activate
                y = 8
                While Cells(y, 1).Value <> " Début Process CONV3 "
                y = y + 1
                Wend
                Cells(y + 3, 1).Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                wbc.Activate
                Sheets("Ond3").Select
                Range("D2").Select
                Selection.End(xlDown).Offset(1, 0).Select   'Copier coller à la suite des données du jour précédent
                ActiveSheet.Paste
                wb2.Close
            End If
        Next J
    End If
End If

'Mise en forme des données
Sheets("Ond1").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
        Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
        33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
        Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
        46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
        Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
        59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), _
        Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array( _
        72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, 1), _
        Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), Array( _
        85, 1), Array(86, 1)), TrailingMinusNumbers:=True
    Range("F2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace what:=".", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Sheets("Ond2").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
        Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
        33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
        Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
        46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
        Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
        59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), _
        Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array( _
        72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, 1), _
        Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), Array( _
        85, 1), Array(86, 1)), TrailingMinusNumbers:=True
    Range("F2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace what:=".", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Sheets("Ond3").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
        Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
        33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
        Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
        46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
        Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
        59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), _
        Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array( _
        72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, 1), _
        Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), Array( _
        85, 1), Array(86, 1)), TrailingMinusNumbers:=True
    Range("F2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace what:=".", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
        
End Sub

EDIT : Ajout du LANGAGE dans les balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.

A voir également:

Macro exécution trop longue
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Jitbit macro recorder - Télécharger - Confidentialité
Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Macro word - Guide
Macro express - Télécharger - Divers Utilitaires

1 réponse

Réponse 1 / 1

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780

Bonjour,

Pour accélérer ton code commence par supprimer tous les .Select. Ils consomment beaucoup de temps inutile.
Il n'est pas nécessaire de sélectionner une plage de cellules pour agir dessus!!!!
Cordialement
Patrice

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780

Par exemple,

Remplaces :

Range("F2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace what:=".", Replacement:=".", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Par

Range("F2").CurrentRegion.Replace what:=".", Replacement:=".", LookAt:=xlPart

. Quoique je ne vois pas l'utilité de cette ligne, tu peux même la supprimer !!!!

Zack

Quand je remplace
Sheets("Ond1").Select
Range("F2").select
par Sheets("Ond1").Range("F2").select ça me met une erreur de selection donc je suis pas sur de pouvoir enlever tous les .Select ...

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780 > Zack

Euh ...
dans Sheets("Ond1").Range("F2").select n'y aurait-il pas un select ?????

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780 > Zack

Un second exemple, remplaces :

    Sheets("Ond1").Select
    Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents

Par :

    Sheets("Ond1").Range("D1").CurrentRegion.ClearContents

Zack

Et cette partie tu la ré arrangerai comment ?
wb1.Activate
Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wbc.Activate
Sheets("Ond1").Select
Range("D1").Select
ActiveSheet.Paste

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro

recup couleur de cellule sans macro

Problème vidéo trop longue pour youtube

EXCEL transformer chiffres en lettre -facture

VERSION EXTRA LONGUE SEIGNEUR DES ANNEAUX

Votre réponse

Discussions similaires