Accélération du code

Le 12/04/2021 à 10:43

Bonjour cher Forum,

Je reviens vers vous pour savoir si le code suivant peut être amélioré ? Je débute dans ce domaine.

Le but → copier des données chaque jours depuis un classeur .csv puis mettre à jour date par date la feuille "Dispo1"

Celui-ci met quelques minutes à s'exécuter.

Sub Copie()
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim Wb3 As Workbook

Application.ScreenUpdating = False
   'ouvrir le fichier source
Application.DisplayAlerts = False
maVariable = Format(Now, "yyyymmdd")
On Error Resume Next
Set Wb = Workbooks.Open("S:\Forum\RM\Statistiques par segmentation\ANNEE 2021\HB0L9_TrackingList_" & maVariable & ".csv")
Workbooks.OpenText ("S:\Forum\RM\Statistiques par segmentation\ANNEE 2021\HB0L9_TrackingList_" & maVariable & ".csv"), Origin:=xlWindows, _
    StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True
If Not Wb Is Nothing Then

        Application.DisplayAlerts = True

'copier les donnés dans destination
Application.DisplayAlerts = False
 Workbooks("HB0L9_TrackingList_" & maVariable & "" & ".csv").Activate
 Selection.AutoFilter
    ActiveSheet.Range("$A$1:$S$1633").AutoFilter Field:=2, Criteria1:="=A2", _
        Operator:=xlOr
Workbooks("HB0L9_TrackingList_" & maVariable & "" & ".csv").Sheets("HB0L9_TrackingList_" & maVariable & "").Range("A1:S6000").Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("D4")
Application.DisplayAlerts = True

'Fermer fichier source
Application.DisplayAlerts = False
Workbooks("HB0L9_TrackingList_" & maVariable & "" & ".csv").Close savechanges:=False
Application.DisplayAlerts = True
Else
    MsgBox "Le classeur suivant n'existe pas RM_HB0L9_TrackingList_:" & maVariable
End If

   'ouvrir le fichier source
Application.DisplayAlerts = False
maVariable = Format(Now, "mmdd")
maVariable2 = "2020"
On Error Resume Next
Set Wb2 = Workbooks.Open("S:\Forum\RM\Statistiques par segmentation\ANNEE 2020\HB0L9_TrackingList_" & maVariable2 & maVariable & ".csv")
Workbooks.OpenText ("S:\Forum\RM\Statistiques par segmentation\ANNEE 2020\HB0L9_TrackingList_" & maVariable2 & maVariable & ".csv"), Origin:=xlWindows, _
    StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True
On Error GoTo 0
If Not Wb2 Is Nothing Then
    Sheets("HB0L9_TrackingList_" & maVariable2 & maVariable & "").Select
    Application.DisplayAlerts = True

'copier les donnés dans destination
Application.DisplayAlerts = False
 Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Activate
 Selection.AutoFilter
    ActiveSheet.Range("$A$1:$S$1633").AutoFilter Field:=2, Criteria1:="=A2", _
        Operator:=xlOr
Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Sheets("HB0L9_TrackingList_" & maVariable2 & maVariable & "").Range("A1:S6000").Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("X4")
Application.DisplayAlerts = True

'Fermer fichier source
Application.DisplayAlerts = False
Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Close savechanges:=False
Application.DisplayAlerts = True
Else
    MsgBox "Le classeur suivant n'existe pas : RM_HB0L9_TrackingList_ " & maVariable2 & maVariable
End If

'ouvrir le fichier source
Application.DisplayAlerts = False
maVariable = Format(Now, "mmdd")
maVariable2 = "2019"
On Error Resume Next
Set Wb3 = Workbooks.Open("S:\Forum\RM\Statistiques par segmentation\ANNEE 2019\HB0L9_TrackingList_" & maVariable2 & maVariable & ".csv")
Workbooks.OpenText ("S:\Forum\RM\Statistiques par segmentation\ANNEE 2019\HB0L9_TrackingList_" & maVariable2 & maVariable & ".csv"), Origin:=xlWindows, _
    StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True
On Error GoTo 0
On Error GoTo 0
If Not Wb3 Is Nothing Then
    Sheets("HB0L9_TrackingList_" & maVariable2 & maVariable & "").Select
    Application.DisplayAlerts = True

'copier les donnés dans destination
Application.DisplayAlerts = False
 Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Activate
 Selection.AutoFilter
    ActiveSheet.Range("$A$1:$S$1633").AutoFilter Field:=2, Criteria1:="=A2", _
        Operator:=xlOr
Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Sheets("HB0L9_TrackingList_" & maVariable2 & maVariable & "").Range("A1:S6000").Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("AR4")
Application.DisplayAlerts = True

'Fermer fichier source
Application.DisplayAlerts = False
Workbooks("HB0L9_TrackingList_" & maVariable2 & maVariable & "" & ".csv").Close savechanges:=False

Else
    MsgBox "Le classeur suivant n'existe pas : RM_HB0L9_TrackingList_" & maVariable2 & maVariable
End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True

Sheets("Dispo1").Range("A6") = (Now)

'mise à jour de la base de donnée

Dim f1 As Worksheet, f2 As Worksheet, i As Long, o As Long, p As Long, ligne As Long, ligne1 As Long, ligne2 As Long
Set f1 = Sheets("Dispo1")
Set f2 = Sheets("Dispo2")

For i = 5 To f2.Range("F" & Rows.Count).End(xlUp).Row
    ligne = f2.Range("F" & i).Value - f1.Range("F5").Value + 5
    f2.Range("G" & i & ":V" & i).Copy Destination:=f1.Range("G" & ligne)
Next
    For o = 5 To f2.Range("Z" & Rows.Count).End(xlUp).Row
        ligne1 = f2.Range("Z" & o).Value - f1.Range("Z5").Value + 5
        f2.Range("AA" & o & ":AP" & o).Copy Destination:=f1.Range("AA" & ligne1)
    Next
        For p = 5 To f2.Range("AT" & Rows.Count).End(xlUp).Row
            ligne2 = f2.Range("AT" & p).Value - f1.Range("AT5").Value + 5
            f2.Range("AU" & p & ":BJ" & p).Copy Destination:=f1.Range("AU" & ligne2)
        Next

 End Sub

Un grand merci par avance !

Le 12/04/2021 à 11:24

Bonjour,

Quelques remarques au fur et à mesure de la lecture de votre code :
- Inutile d'ouvrir 2 fois de suite le même fichier (Workbooks.Open)
- Pour la clarté de lecture du code : utiliser l'indentation pour identifier plus facilement les structures du codes + mettre des commentaires (au bon endroit)
- .Select et .Activate à éviter autant que possible : ils sont inutiles dans la mesure où l'objet manipulé est précisé
- Certaines variables ne sont pas déclarées (maVariable, maVariable2, etc)
- Utiliser des noms de variables plus explicites que maVariable...
- Répétitions de Application.DisplayAlerts complètement inutiles
- Répétitions de gestion d'erreur complètements inutiles
- La gestion d'erreur (OnError...) est à éviter ici, au moins pour comprendre et rectifier les éventuels problèmes d'exécution du code
- Une même variable peut-être rémployée (Wb par exemple)
- Les déclarations de variables sont à grouper en début de macro

Code modifié (mais non testé... il y aura probablement des modifications à apporter) :

Sub Copie()

Dim Wb As Workbook, DateJour As String
Dim f1 As Worksheet, f2 As Worksheet, i As Long, ligne As Long

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
DateJour = Format(Date, "yyyymmdd")
Set Wb = Workbooks.OpenText("S:\Forum\RM\Statistiques par segmentation\ANNEE 2021\HB0L9_TrackingList_" & DateJour & ".csv", Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True)
If Not Wb Is Nothing Then
    With Wb.Sheets(1).Range("A1").CurrentRegion
        .AutoFilter Field:=2, Criteria1:="=A2", Operator:=xlOr
        .Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("D4")
    End With
    Wb.Close False
Else
    MsgBox "Le classeur suivant n'existe pas : RM_HB0L9_TrackingList_" & DateJour
End If
'2nd fichier
DateJour = Year(Date) - 1 & Format(Date, "mmdd") 
Set Wb = Workbooks.OpenText("S:\Forum\RM\Statistiques par segmentation\ANNEE 2020\HB0L9_TrackingList_" & DateJour & ".csv", Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True)
If Not Wb Is Nothing Then
    With Wb.Sheets(1).Range("A1").CurrentRegion
        .AutoFilter Field:=2, Criteria1:="=A2", Operator:=xlOr
        .Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("X4")
    End With
    Wb.Close False
Else
    MsgBox "Le classeur suivant n'existe pas : RM_HB0L9_TrackingList_" & DateJour
End If
'3ème fichier
DateJour = Year(Date) - 2 & Format(Date, "mmdd")
Set Wb = Workbooks.OpenText("S:\Forum\RM\Statistiques par segmentation\ANNEE 2020\HB0L9_TrackingList_" & DateJour & ".csv", Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True)
If Not Wb Is Nothing Then
    With Wb.Sheets(1).Range("A1").CurrentRegion
        .AutoFilter Field:=2, Criteria1:="=A2", Operator:=xlOr
        .Copy Workbooks("Hotel Dashboard 2020.xlsm").Worksheets("Dispo2").Range("AR4")
    End With
    Wb.Close False
Else
    MsgBox "Le classeur suivant n'existe pas : RM_HB0L9_TrackingList_" & DateJour
End If
'Mise à jour de la base de donnée
Set f1 = Sheets("Dispo1")
Set f2 = Sheets("Dispo2")
f1.Range("A6") = Now
For i = 5 To f2.Range("F" & Rows.Count).End(xlUp).Row
    ligne = f2.Range("F" & i).Value - f1.Range("F5").Value + 5
    f2.Range("G" & i & ":V" & i).Copy Destination:=f1.Range("G" & ligne)
Next
For i = 5 To f2.Range("Z" & Rows.Count).End(xlUp).Row
    ligne = f2.Range("Z" & i).Value - f1.Range("Z5").Value + 5
    f2.Range("AA" & i & ":AP" & i).Copy Destination:=f1.Range("AA" & ligne)
Next
For i = 5 To f2.Range("AT" & Rows.Count).End(xlUp).Row
    ligne = f2.Range("AT" & i).Value - f1.Range("AT5").Value + 5
    f2.Range("AU" & i & ":BJ" & i).Copy Destination:=f1.Range("AU" & ligne)
Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.Calculation = xlCalculationAutomatic

End Sub
Le 12/04/2021 à 14:20

Bonjour,

Oui effectivement comme je me doutais il y a beaucoup de problèmes... Je vais modifier cela.

Merci beaucoup de votre aide, sur le .OpenText j'ai une erreur "fonction ou variable attendue".

Concernant la gestion des erreurs, elle est utile car il se peut que le fichier n'existe pas.

Le 12/04/2021 à 14:58
JESSY9468 a écrit :

Concernant la gestion des erreurs, elle est utile car il se peut que le fichier n'existe pas.

Vous avez déjà une condition If pour tester si Wb représente qq chose. Si ça ne fonctionne pas ainsi, testez plutôt avant d'ouvrir le fichier s'il existe avec la commande suivante :

If Len(Dir(NomCompletClasseur)) > 0 Then
    '... gnagnagna
Else
    MsgBox "Le fichier " & NomClasseur & " n'existe pas !"
End If

Car une gestion d'erreur ne s'occupera pas de l'origine de l'erreur, alors pour déboguer un programme, ce n'est pas le plus pratique...

Le 12/04/2021 à 15:03

j'ai modifier avec if pour tester mais le code s'interrompt en me disant que le fichier est introuvable. Pourtant j'ai bien le message la msgbox

Le 12/04/2021 à 15:04
JESSY9468 a écrit :

j'ai modifier avec if pour tester mais le code s'interrompt en me disant que le fichier est introuvable. Pourtant j'ai bien le message la msgbox

Peux tu partager des fichiers anonymisés que l'on tente de faire fonctionner ce code sur quelque chose de similaire à ce que tu fais ?

Le 12/04/2021 à 15:14

j'ai réussi en ce qui concerne le Workbooks.OpenText.

il reste maintenant la gestion des fichiers manquants avec If Not Wb Is Nothing Then mais cela ne me semble pas à sa place.

J'ai voulu mettre le fichier mais il est trop lourd, le but de celui-ci est d'obtenir un tableau de bord.

Le 12/04/2021 à 15:26

Si tu souhaites nous les transmettre, allège tes fichiers au strict minimum pour que la macro puisse fonctionner.

Le problème de ta macro actuelle, c'est que essayes d'abord d'ouvrir un fichier avant de savoir s'il existe. La procédure indiqué plus haut te permet de faire les test avant l'ouverture, et vient remplacer ton If Not Wb Is Nothing Then actuel.

Le 12/04/2021 à 16:46

J'ai supprimer beaucoup de choses pour le faire passer, mais toujours pas...

Rechercher des sujets similaires à "acceleration code"