Aide pour optimisation de code

[bobylaroche]

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

 

[bobylaroche]

Re : Aide pour optimisation de code

Oui, cela ne me gêne pas si les nouvelles données se retrouvent vers le bas mais il faut que tu me dises quelle ligne changer !

 

[bobylaroche]

Re : Aide pour optimisation de code

Je viens de penser à une chose, il serait possible d'ajouter un compteur en colonne A ? Ainsi je pourrais obtenir l'ordre avec un tri décroissant lorsque je le souhaite

 

[bobylaroche]

Re : Aide pour optimisation de code

Merci Benoit, je regarde cela tout à l'heure.

 

[bobylaroche]

Re : Aide pour optimisation de code

Bonjour Benoit,
S'il te plait, je ne parviens pas à comprendre "Remplacer tous les [xx5] par range ("xx" & ligne)"
Dur, dur !

 

[thebenoit59]

Re : Aide pour optimisation de code

Voilà le code à jour, avec ajout de compteur dans la colonne A.

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, Ligne As Long

Sub ImportClasseurs()
Set WkImp = ThisWorkbook
Set ShT1 = WkImp.Sheets("T1")
Ligne = ShT1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
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")
        Ligne = Ligne + 1
        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.Range("B" & Ligne).Resize(1, 7) = Application.Transpose(r1)
        Sh.Range("A" & Ligne).Value = Ligne - 3
    Next i
    
    ' Unique à T1
    r2 = ShSource.Range("b12:b103").Value
    ShT1.Range("I" & Ligne).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.Range("BS" & Ligne).Resize(1, 5) = Application.Transpose(r3)
        Sh.Range("I" & Ligne).Resize(1, 92) = Application.Transpose(r4)
    Next i
End Sub

 

[bobylaroche]

Re : Aide pour optimisation de code

Merci, c'est gentil, je termine mon repas et j'y retourne

 

[bobylaroche]

Re : Aide pour optimisation de code

J'étais en train de cogiter pour le compteur

 

[bobylaroche]

Re : Aide pour optimisation de code

Le dernier code fonctionne hormis pour les arrivées "Export(B74:B78)".
En effet, seule la feuille T1 comporte l'arrivée.
J'ai essayé de modifier les boucles que l'on trouve en fin de sub mais rien de positif.

 

[thebenoit59]

Re : Aide pour optimisation de code

Inverse les deux lignes comme ci-dessous :

        Sh.Range("I" & Ligne).Resize(1, 92) = Application.Transpose(r4)
        Sh.Range("BS" & Ligne).Resize(1, 5) = Application.Transpose(r3)

En effet en inscrivant les valeurs r4 on écrasait les arrivées.

 

[bobylaroche]

Re : Aide pour optimisation de code

Nickel, trop content
Ce soir, je vais lui donner à manger voir comment il ingurgite
Merci

 

[bobylaroche]

Re : Aide pour optimisation de code

Bonjour Benoit,
Après quelques tests et un nombre important de lignes, seulement quelques minutes d'importation au lieu de quelques heures Deux dernières questions si ce n'est pas abusé. Si je souhaite que l'importation des feuilles (T1 à T61) se réalise à partir de la cellule B5 et pas B4, ou se situe le code à modifier ? (j'ai une feuille de stats qui ne comprends plus si B4 et j'ai essayé des modifs sans succès). La dernière, si la feuille export comporte des cellules de couleurs, puis je en conserver le format ? En tous cas, merci, le fichier fonctionne super bien

 

[thebenoit59]

Re : Aide pour optimisation de code

Pour la ligne :

Set ShT1 = WkImp.Sheets("T1")
Ligne = ShT1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
Repert = ThisWorkbook.Path

Par

Set ShT1 = WkImp.Sheets("T1")
Ligne = ShT1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
If Ligne = 3 Then Ligne = 4
Repert = ThisWorkbook.Path

Si tu souhaites conserver le format, la méthode ne fonctionnera pas et il faudra repartir sur du copier-coller.

 

[bobylaroche]

Re : Aide pour optimisation de code

Entendu, merci Benoit, je laisse comme c'est, cela fonctionne super bien.
Puis conserver le format aurait encore joué sur le temps d'importation. Merci pour tout
Bon week-end à tous les XLDNautes et les autres bien sur