VBA : Ouverture de plusieurs fichiers .XLS trés longue

Le 31/07/2018 à 11:40

Bonjour,

Dans l'objectif de construire un tableau de bord je dois faire un code VBA me permettant d'aller, en fonction de numéros de série renseigné dans la première colonne de ma feuille, récupérer des données dans des fichiers Excel placé dans des dossiers différents.

Dans l'idée, je dois pour chaque numéro de série :

  • Atteindre le dossier ou se trouve toutes les données relatives à ce numéro de série
  • Ouvrir tous les fichiers Excel qui m'intéresse un à un
  • Lors de l'ouverture d'un fichier je dois :
- Regarder l'emplacement de la dernière valeur d'une colonne

- Lire cette cellule et en fonction de sa valeur je donne une valeur ou une autre à une variable x

  • Je ferme le fichier sans rien enregistrer
  • J'écris la valeur de la variable x à côté de mon numéro de série.

J'ai fait une code qui réalise exactement ce que je voudrais, le seul problème c'est qu'il lui faut une nuit pour tout traiter ...

(J'ai environ 4000 numéro de série avec en moyenne 3 fichiers Excel à traiter).

J'ai essayé d'optimiser mon code le plus possible (tout du moins pour la boucle de traitement des fichiers) mais là je suis un peu à court d'idées.... est ce que quelqu'un connaitrai un code plus efficace ou saurait me donner des astuces pour optimiser celui ci ?

D'avance merci

Le code :

Sub Recup_Data()

Dim CompteurTablBord As Integer

Dim NbValRequete As Integer

Dim ColDate As Integer

Dim ColTest As Integer

Dim NbLigType As Integer

Dim lien1 As String

Dim lien2 As String

Dim TestEquil As String

Dim DatePVC As String

Dim NumSerieSER As String

Dim LienDossier As String

Dim lienfichier As String

Dim Wb As Workbook

Dim début As Date

Dim fin As Date

Dim TempsExecution As Date

début = Time

Application.ScreenUpdating = False

Application.Calculation = xlManual

'Copier données requete BDD dans feuille travail

Sheets("Requête Equil Proto").Columns("A:A").Copy

Sheets("Données PVC EXcel").Select

Columns("A:A").Select

ActiveSheet.Paste

'Supprimer les doublons

Columns("A:A").Select

Application.CutCopyMode = False

ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

'Compter nombre de SER pour compteur

NbValRequete = Application.CountA([A:A])

'Création des parties de lien

lien1 = "\\mtl-srv-prod\cristal$\Mesures SER\"

lien2 = "\Equil_triaxes\Mes_bal\"

'Compteur pour défilement des numéros de série du tableau de bord

For CompteurTablBord = 2 To NbValRequete

ColDate = 2

ColTest = 3

'Récupération du Num série

NumSerieSER = Worksheets("Données PVC Excel").Cells(CompteurTablBord, 1).Value

'Création du lien

LienDossier = lien1 & NumSerieSER & lien2

lienfichier = Dir(LienDossier & "EQUI_CRISTAL" & "*.xls")

'Balayage des fichier Excel dans les dossiers indiqués par les liens

Do While lienfichier <> ""

'On ouvre le fichier

Set Wb = Workbooks.Open(LienDossier & lienfichier)

'On cherche la cellule ou se trouve la dernière valeur de la colonne

NbLigType = Worksheets("D_MRE").Range("E" & Rows.Count).End(xlUp).Row

'On regarde la dernière valeur et on identifie equil/remesure en fonction de la valeur

If Worksheets("D_MRE").Cells(NbLigType, 4) = 99 Then

TestEquil = "Equilibrage"

DatePVC = Worksheets("PV SER EQUI").Cells(7, 3).Value

ElseIf Worksheets("D_MRE").Cells(NbLigType, 4) = 94 Then

TestEquil = "Remesure"

DatePVC = Worksheets("PV SER EQUI").Cells(7, 3).Value

End If

'Fermer sans faire d'enregistrement

Application.DisplayAlerts = False

Wb.Close

Application.DisplayAlerts = True

'Copie des données

Worksheets("Données PVC Excel").Cells(CompteurTablBord, ColDate) = DatePVC

Worksheets("Données PVC Excel").Cells(CompteurTablBord, ColTest) = TestEquil

'Continuer le balayement des fichier XLS

lienfichier = Dir

ColDate = ColDate + 2

ColTest = ColTest + 2

Loop

Next

Application.ScreenUpdating = True

Application.Calculation = xlAutomatic

fin = Time

TempsExecution = fin - debut

MsgBox (TempsExecution)

End Sub

Le 31/07/2018 à 12:03

Bonjour,

Je crois que ton erreur viens de :

Application.Calculation = xlManual
Application.Calculation = xlAutomatic
'Qui s'écrivent, je crois :
Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic

Essaie ça et redis moi.

Le 31/07/2018 à 12:32

Bonjour,

Aussi, en enlevant les "Select", il devrait y avoir amélioration du temps d'exécution...

Sub Recup_Data()
Dim CompteurTablBord As Integer
Dim NbValRequete As Integer
Dim ColDate As Integer
Dim ColTest As Integer
Dim NbLigType As Integer
Dim lien1 As String
Dim lien2 As String
Dim TestEquil As String
Dim DatePVC As String
Dim NumSerieSER As String
Dim LienDossier As String
Dim Lienfichier As String
Dim Wb As Workbook
Dim début As Date
Dim fin As Date
Dim TempsExecution As Date

début = Time

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

        'Copier données requete BDD dans feuille travail
Sheets("Requête Equil Proto").Columns("A:A").Copy Sheets("Données PVC EXcel").Columns("A:A")

        'Supprimer les doublons
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

        'Compter nombre de SER pour compteur
NbValRequete = Application.CountA([A:A])

        'Création des parties de lien
        'lien1 = "\\mtl-srv-prod\cristal$\Mesures SER\"
        'lien2 = "\Equil_triaxes\Mes_bal\"
        'Compteur pour défilement des numéros de série du tableau de bord

For CompteurTablBord = 2 To NbValRequete
    ColDate = 2
    ColTest = 3
            'Récupération du Num série
    NumSerieSER = Worksheets("Données PVC Excel").Cells(CompteurTablBord, 1).Value
            'Création du lien
    LienDossier = lien1 & NumSerieSER & lien2
    Lienfichier = Dir(LienDossier & "EQUI_CRISTAL" & "*.xls")
            'Balayage des fichier Excel dans les dossiers indiqués par les liens
    Do While Lienfichier <> ""
                'On ouvre le fichier
        Set Wb = Workbooks.Open(LienDossier & Lienfichier)
                'On cherche la cellule ou se trouve la dernière valeur de la colonne
        NbLigType = Worksheets("D_MRE").Range("E" & Rows.Count).End(xlUp).Row
                'On regarde la dernière valeur et on identifie equil/remesure en fonction de la valeur
        If Worksheets("D_MRE").Cells(NbLigType, 4) = 99 Then
            TestEquil = "Equilibrage"
            DatePVC = Worksheets("PV SER EQUI").Cells(7, 3).Value
        ElseIf Worksheets("D_MRE").Cells(NbLigType, 4) = 94 Then
            TestEquil = "Remesure"
            DatePVC = Worksheets("PV SER EQUI").Cells(7, 3).Value
        End If
                'Fermer sans faire d'enregistrement
        Application.DisplayAlerts = False
        Wb.Close
        Application.DisplayAlerts = True
                'Copie des données
        Worksheets("Données PVC Excel").Cells(CompteurTablBord, ColDate) = DatePVC
        Worksheets("Données PVC Excel").Cells(CompteurTablBord, ColTest) = TestEquil
                'Continuer le balayement des fichier XLS
        Lienfichier = Dir
        ColDate = ColDate + 2
        ColTest = ColTest + 2
    Loop
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

fin = Time
TempsExecution = fin - début
MsgBox (TempsExecution)

End Sub

ric

Le 31/07/2018 à 16:48

Bonjour et merci pour vos retours,

Ric : Effectivement les "select" sont pas terribles, mais ils ne rentrent dans aucune boucle(et donc n'interviennent qu'une seule fois dans mon code), je ne pense pas qu'il soient la cause de la lenteur. Ceci dit j'ai fait la modification, ça coute rien et c'est plus propre

Le 31/07/2018 à 17:02

Pedro: J'ai fait la modification mais il n'y a pas d'impact à première vue, et puis j'ai l'impression que les deux écritures s'appliquent.

D'après un collègue "softeux" cette lenteur peut venir de deux choses :

- Le fait que les fichiers .xls que je souhaite scruter soit sur un serveur partagé ralentit l'exécution (Test fait avec 10 fichiers: on passe du simple au double niveau temps de traitement). Le problème avec la copie en local c'est que vu la lourdeur des informations, il faut 4h30 pour tout transférer ..

- A priori il existerai des solutions pour aller chercher des informations dans des fichiers Excel sans les ouvrir (dans le cas de cellules de destination fixes), la piste consisterait donc à voir si il est possible d'adapter cette solution à mon problème..

Je vais continuer de gratter, si quelqu'un a une idée je suis preneur et si j'ai une piste je ferai une petite MAJ.

Rechercher des sujets similaires à "vba ouverture fichiers xls tres longue"