Aide pour optimisation de code

B

bobylaroche

XLDnaute Occasionnel
Bonjour à tous, XLDNautes et visiteurs,


Voili, voila, nouveaux soucis !

Le sujet :
Au quotidien, j'ai entre 10 et 40 classeurs source contenant chacun 61 classements (T1 à T61).
Ces classements figurent sur une feuille commune nommée EXPORT .

A l'aide d'un classeur nommé BD (devenu escargot), j'importais donc au quotidien tous ces classements afin de réaliser une base de données.

Une première tentative :
Un premier classeur (l'escargot) a était conçu mais au fil du temps l'importation quotidienne est devenue hyper lente, parfois plus de 6 heures ! J'ai essayé d'interrompre les calculs et de remettre en automatique au moment utile, de désactiver l'actualisation de l'écran, etc..., rien n'y a fait.
Faut dire qu'il contenait environ 1000 lignes par classement et que c'était un véritable patchwork de macros dupliquées allant piochées ça et là..

J'ai réalisé un nouveau code qui fonctionne mais je souhaiterai le corriger/l'optimiser pour ne pas être une nouvelle fois déçu.

Tite question, pensez vous que deux classeurs BD plutôt qu'un, soit 30 classements par classeur allégerait de beaucoup l'importation ?.

Ci-dessous le code, mais étant plus bidouilleur qu'autre chose, il doit être possible de l'optimiser.
Seulement trois classements pour l'exemple (T1 à T3) car mis à part T1, ce sont les mêmes "routines" seules les plages diffères.


Si vous avez des conseils, des idées, je suis tout ouïe :)
Par avance, merci.


Pour une meilleure compréhension, 2 fichiers sources et le fichier BD en pièce jointe.


-------------------------------

Sub ImportClasseurs()
'
' ImportClasseurs Macro
'
Application.ScreenUpdating = False
'
Dim cellule As Range
Dim Nom_fic(100) As String
Dim Wb As Workbook
Dim rep As String

Application.DisplayAlerts = False
Sheets("IMPORT").Activate
derli = 5
rep = ActiveWorkbook.Path

Direction = Dir(rep & "\*.xls*")
nbfic = 0
While Direction > ""
If Direction = ActiveWorkbook.Name Then GoTo suite
nbfic = nbfic + 1
Nom_fic(nbfic) = Direction
suite:
Direction = Dir()
Wend
For x = 1 To nbfic
fg = rep & "\" & Nom_fic(x)

Set Wb = GetObject(fg)


' T1
'' Copie Date, h,r,c,p,al,ty
Sheets("T1").Select
Rows("5:5").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Wb.Sheets("EXPORT").Range("B5:B11").Copy
Sheets("T1").Select
Range("B" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'' Copie Classements & Valeurs
Wb.Sheets("EXPORT").Range("B12:B103").Copy
Sheets("T1").Select
Range("i" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True


' T2
'' Copie Date, h,r,c,p,al,ty
Sheets("T2").Select
Rows("5:5").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Wb.Sheets("EXPORT").Range("b5:b11").Copy
Sheets("T2").Select
Range("B" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'' Copie Classements & Valeurs
Wb.Sheets("EXPORT").Range("e12:e103").Copy
Sheets("T2").Select
Range("i" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
' Arrivée
Wb.Sheets("EXPORT").Range("b74:b78").Copy
Sheets("T2").Select
Range("BS" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True


' T3
'' Copie Date, h,r,c,p,al,ty
Sheets("T3").Select
Rows("5:5").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Wb.Sheets("EXPORT").Range("b5:b11").Copy
Sheets("T3").Select
Range("B" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'' Copie Classements & Valeurs
Wb.Sheets("EXPORT").Range("f12:f103").Copy
Sheets("T3").Select
Range("i" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
' Arrivée
Wb.Sheets("EXPORT").Range("b74:b78").Copy
Sheets("T3").Select
Range("BS" & derli).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

Application.WindowState = xlMaximized

Wb.Close
Next x
fin:
Application.DisplayAlerts = True
 

Pièces jointes

  • BD.xlsm
    33.1 KB · Affichages: 39
  • 110416-1.2.14-EXP.xlsx
    48.2 KB · Affichages: 24
  • 110416-1.9.17-EXP.xlsx
    79.4 KB · Affichages: 27
  • BD.xlsm
    33.1 KB · Affichages: 35
Trier par date Trier par votes
vgendron

vgendron

XLDnaute Barbatruc
Re : Aide pour optimisation de code

Bonjour,

Ci -joint ton code modifié avec quelques commentaires
Je ne sais pas si ce sera plus rapide, en tout cas, je sais que tous les select sont gourmands et qu'on peut s'en passer

Code: 
Sub ImportClasseurs()
'
' ImportClasseurs Macro
'
Application.ScreenUpdating = False
'
Dim cellule As Range
Dim Nom_fic(100) As String
Dim Wb As Workbook
Dim rep As String

Application.DisplayAlerts = False
'aucun interet puisque tu es déjà dedans au moment de cliquer sur le bouton
Sheets("IMPORT").Activate
derli = 5

'récupère le path du classeur actif
rep = ActiveWorkbook.Path

'compte le nombre de fichiers Excel dans le répertoire ?
Direction = Dir(rep & "\*.xls*")
nbfic = 0
While Direction > ""
    If Direction = ActiveWorkbook.Name Then GoTo suite
    nbfic = nbfic + 1
    Nom_fic(nbfic) = Direction
suite:
    'à quoi sert ce tableau de nom? il n'est pas utilisé après
    Direction = Dir()
Wend

For x = 1 To nbfic
    fg = rep & "\" & Nom_fic(x)
    Set Wb = GetObject(fg)

    ' T1
    '' Copie Date, h,r,c,p,al,ty
    Sheets("T1").Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Wb.Sheets("EXPORT").Range("B5:B11").Copy
    Sheets("T1").Range("B" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    
    '' Copie Classements & Valeurs
    Wb.Sheets("EXPORT").Range("B12:B103").Copy
    Sheets("T1").Range("i" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True


    ' T2
    '' Copie Date, h,r,c,p,al,ty
    Sheets("T2").Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Wb.Sheets("EXPORT").Range("b5:b11").Copy
    Sheets("T2").Range("B" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

    '' Copie Classements & Valeurs
    Wb.Sheets("EXPORT").Range("e12:e103").Copy
    Sheets("T2").Range("i" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ' Arrivée
    Wb.Sheets("EXPORT").Range("b74:b78").Copy
    Sheets("T2").Range("BS" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
                 

    ' T3
    '' Copie Date, h,r,c,p,al,ty
    Sheets("T3").Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Wb.Sheets("EXPORT").Range("b5:b11").Copy
    Sheets("T3").Range("B" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

    '' Copie Classements & Valeurs
    Wb.Sheets("EXPORT").Range("f12:f103").Copy
    Sheets("T3").Range("i" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ' Arrivée
    Wb.Sheets("EXPORT").Range("b74:b78").Copy
    Sheets("T3").Range("BS" & derli).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

    Application.WindowState = xlMaximized
    Wb.Close
Next x
fin:
Application.DisplayAlerts = True

'
End Sub
 
Vote positif 0 Vote négatif
B

bobylaroche

XLDnaute Occasionnel
Re : Aide pour optimisation de code

Bonjour Benoit,
Lorsque je test, les lignes s'incrémentent correctement et ne s'écrasent pas.
En fait, il n'y a pas de réelle boucle, le classement est collé en ligne 5 avec Selection.Insert Shift, ce qui fait décaler toutes les autres lignes d'une ligne.
C'est fonctionnel mais pour le code, vous avez le droit de vous marrer ;)
 
Vote positif 0 Vote négatif
T

thebenoit59

XLDnaute Accro
Re : Aide pour optimisation de code

Une autre solution pour optimiser ton code :
Code: 
Dim WkImp As Workbook, WkSource As Workbook
Dim ShT1 As Worksheet, ShT2 As Worksheet, ShT3 As Worksheet, ShSource As Worksheet
Dim lT1 As Long, lT2 As Long, lT3 As Long
Dim Repert As String, Fichier As String, Origine As String
Dim r, Ligne As Long

Sub ImportClasseurs()
Set WkImp = ThisWorkbook
Set ShT1 = WkImp.Sheets("T1"): Set ShT2 = WkImp.Sheets("T2"): Set ShT3 = WkImp.Sheets("T3")
Repert = ThisWorkbook.Path
Origine = ThisWorkbook.Name
Sep = Application.PathSeparator
If ShT1.Cells.Find("*", , , , xlByRows, xlPrevious).Row = 3 Then
    Ligne = 1
    Else: Ligne = 93
End If
Fichier = Dir(Repert + Sep + "*.xls*")
Do While Fichier <> ""
    If Fichier <> Origine Then
        Set WkSource = Workbooks.Open(Repert + Sep + Fichier)
        Set ShSource = WkSource.Sheets("EXPORT")
        Copier_Resultats
        WkSource.Close False
    End If
    Fichier = Dir
Loop
End Sub

Sub Copier_Resultats()
    ' Feuille T1
    ShT1.Rows(5).Resize(Ligne, 1).EntireRow.Insert Shift:=xlDown
    
    ' Feuille T1
    r = ShSource.Range("b5:b11").Value '
    ShT1.[b5].Resize(7, 1) = r
    ShT2.[b5].Resize(7, 1) = r
    ShT3.[b5].Resize(7, 1) = r
    r = ShSource.Range("b12:b103").Value
    ShT1.[i5].Resize(92, 1) = r

    ' Feuille T2
    r = ShSource.Range("e12:e103").Value 'Classements
    ShT2.[i5].Resize(92, 1) = r
    r = ShSource.Range("b74:b78").Value 'Arrivée
    ShT2.[bs5].Resize(5, 1) = r
    ShT3.[bs5].Resize(5, 1) = r

    ' Feuille T3
    r = ShSource.Range("f12:f103").Value 'Classements
    ShT3.[i5].Resize(92, 1) = r
    
    Ligne = 93
End Sub

Code que nous pourrions facilement optimiser en bouclant les onglets quand nous avons les mêmes valeurs à insérer, je pense à l'arrivée par exemple.
 
Vote positif 0 Vote négatif
T

thebenoit59

XLDnaute Accro
Re : Aide pour optimisation de code

Et un code avec boucles :
Code: 
Option Explicit
Dim WkImp As Workbook, WkSource As Workbook
Dim ShT1 As Worksheet, ShSource As Worksheet
Dim lT1 As Long, lT2 As Long, lT3 As Long
Dim Repert As String, Fichier As String, Origine As String, Sep As String
Dim r1, r2, r3, r4, Ligne As Long

Sub ImportClasseurs()
Set WkImp = ThisWorkbook
Set ShT1 = WkImp.Sheets("T1")
Repert = ThisWorkbook.Path
Origine = ThisWorkbook.Name
Sep = Application.PathSeparator
If ShT1.Cells.Find("*", , , , xlByRows, xlPrevious).Row = 3 Then
    Ligne = 1
    Else: Ligne = 93
End If
Fichier = Dir(Repert + Sep + "*.xls*")
Do While Fichier <> ""
    If Fichier <> Origine Then
        Set WkSource = Workbooks.Open(Repert + Sep + Fichier)
        Set ShSource = WkSource.Sheets("EXPORT")
        Copier_Resultats
        WkSource.Close False
    End If
    Fichier = Dir
Loop
End Sub

Sub Copier_Resultats()
Dim i As Integer, j As Integer
Dim Sh As Worksheet
    ' Communs à toutes les feuilles T(i)
    r1 = ShSource.Range("b5:b11").Value ' A boucler
    For i = 2 To 4 'Nombre selon nécessité - si T61: i = 2 To 62
        Set Sh = WkImp.Sheets(i)
        Sh.Rows(5).Resize(Ligne, 1).EntireRow.Insert Shift:=xlDown
        Sh.[b5].Resize(7, 1) = r1
    Next i
    
    ' Unique à T1
    r2 = ShSource.Range("b12:b103").Value
    ShT1.[i5].Resize(92, 1) = r2

    ' Arrivées pour Feuilles T2 à T(i)
    r3 = ShSource.Range("b74:b78").Value
    For i = 3 To 4 ' si T61 : 1 = 2 To 62
        j = i - 3
        r4 = ShSource.Range("e12:e103").Offset(, j).Value
        Set Sh = WkImp.Sheets(i)
        Sh.[bs5].Resize(5, 1) = r3
        Sh.[i5].Resize(92, 1) = r4
    Next i
    
Ligne = 93
End Sub
 
Vote positif 0 Vote négatif
B

bobylaroche

XLDnaute Occasionnel
Re : Aide pour optimisation de code

Merci Benoit, cela devient hermétique pour moi, oups.
Il y a un souci. Au final, j'obtiens une seule ligne verticale avec tous les classements les uns en dessous des autres au lieu d'une incrémentation de lignes horizontales.
 
Vote positif 0 Vote négatif
T

thebenoit59

XLDnaute Accro
Re : Aide pour optimisation de code

Il est normal que le soucis soit toujours présente car j'avais réalisé les boucles avant que tu ne postes ta réponse :)

Voilà sans soucis de lignes :

Code: 
Option Explicit
Dim WkImp As Workbook, WkSource As Workbook
Dim ShT1 As Worksheet, ShSource As Worksheet
Dim Repert As String, Fichier As String, Sep As String
Dim r1, r2, r3, r4

Sub ImportClasseurs()
Set WkImp = ThisWorkbook
Set ShT1 = WkImp.Sheets("T1")
Repert = ThisWorkbook.Path
Sep = Application.PathSeparator
Fichier = Dir(Repert + Sep + "*.xls*")
Application.ScreenUpdating = False
Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        Set WkSource = Workbooks.Open(Repert + Sep + Fichier)
        Set ShSource = WkSource.Sheets("EXPORT")
        Copier_Resultats
        WkSource.Close False
    End If
    Fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub

Sub Copier_Resultats()
Dim i As Integer, j As Integer
Dim Sh As Worksheet
    ' Communs à toutes les feuilles T(i)
    r1 = ShSource.Range("b5:b11").Value ' A boucler
    For i = 2 To 4 'Nombre selon nécessité - si T61: i = 2 To 62
        Set Sh = WkImp.Sheets(i)
        Sh.Rows(5).EntireRow.Insert Shift:=xlDown
        Sh.[b5].Resize(1, 7) = Application.Transpose(r1)
    Next i
    
    ' Unique à T1
    r2 = ShSource.Range("b12:b103").Value
    ShT1.[i5].Resize(1, 92) = Application.Transpose(r2)

    ' Arrivées pour Feuilles T2 à T(i)
    r3 = ShSource.Range("b74:b78").Value
    For i = 3 To 4 ' si T61 : 1 = 2 To 62
        j = i - 3
        r4 = ShSource.Range("e12:e103").Offset(, j).Value
        Set Sh = WkImp.Sheets(i)
        Sh.[bs5].Resize(1, 5) = Application.Transpose(r3)
        Sh.[i5].Resize(1, 92) = Application.Transpose(r4)
    Next i
End Sub
 
Vote positif 0 Vote négatif
B

bobylaroche

XLDnaute Occasionnel
Re : Aide pour optimisation de code

Benoit,
Génial ! et il me semble déjà prêt à traiter les 61 classements et onglets :) En moins de 50 lignes !
Dire que mon premier classeur en comportait quelques centaines, j'ai honte !
Dès ce soir, j'ajoute les autres onglets. J'ai hâte de voir le comportement du classeur lorsqu'il y aura les 1000 lignes par onglet.

Je vous tiens informé.

Merci à vous deux et à tous les XLDNautes qui donnent de leur temps.
 
Vote positif 0 Vote négatif
T

thebenoit59

XLDnaute Accro
Re : Aide pour optimisation de code

Tu peux encore gagner du temps. Au lieu d'ajouter une ligne à chaque fois, on peut demander d'ajouter à la dernière ligne + 1,
On détermine la dernière ligne au début de la procédure et on incrémente d'un à chaque nouveau fichier ouvert.
 
Vote positif 0 Vote négatif
T

thebenoit59

XLDnaute Accro
Re : Aide pour optimisation de code

thebenoit59 à dit:
Tu peux encore gagner du temps. Au lieu d'ajouter une ligne à chaque fois, on peut demander d'ajouter à la dernière ligne + 1,
On détermine la dernière ligne au début de la procédure et on incrémente d'un à chaque nouveau fichier ouvert.
Cliquez pour agrandir...

Remplacer tous les [xx5] par range ("xx" & ligne)
Déclarer ligne en Long en public
Au début de la procédure après Set ShT1: ligne = ShT1.Cells.find ("*",,,,xlbyrows,xlprevious).row
Avant le Copier_Resultat de la boucle While ajouter: ligne = ligne + 1
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
256
robpellan52
R
F
  • Résolu(e)
Microsoft 365 Message Box oui/non
Réponses
2
Affichages
108
Francky79
F
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
324
gwenn49
G
O
  • Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
436
olivier388
O
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
517
mouchtre
mouchtre
Usine à gaz
  • Résolu(e)
XL 2021 Coller "RdV Fait Facturé" de "J" ligne active jusqu'à "J" dernière ligne NON vide
2
Réponses
27
Affichages
588
TooFatBoy
TooFatBoy
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
302
Usine à gaz
Usine à gaz
M
  • Question
Microsoft 365 Erreur de format
Réponses
5
Affichages
98
Marvin57
M
F
  • Résolu(e)
XL 2021 Réaliser une macro pour copier une ligne avec formule ?
Réponses
4
Affichages
363
fanou06
F

Membres actuellement en ligne

2 membres et 35 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 084
Messages
2 085 194
Membres
102 813
dernier inscrit
kaiyi