Macro de remplissage trop lourde

[DRILL]

Bonjour a tous,

Ci-joint un fichier de synthèse, relation entre équipement et pièces.
J'ai bidouille une macro pour remplir dans une liste d'équipement les infos des pièces de rechanges (stock, couts, utilisation..), ce a partir de l'item# des pièces que l'on retrouve dans chacun des fichiers.
Ca marche bien avec 100 lignes.
Mon problème c'est que le fichier d'équipement en fait + de 40.000 et mon fichier contenant les infos des pièces + de 10.000... Donc cette macro peut tourner toute la nuit.. Et je n'ai pas ce délai pour analyser les résultats.

Ci quelqu'un peut m'aider à simplifier le code.. Welcome.

Slts
Drill

 

[Compte Supprimé 979]

Re : Macro de remplissage trop lourde

Bonjour Drill,

Puisque tu remplies on ton tableau en effectuant un recherche sur l'Item#
simplifier le code me parait impossible ...

En revanche tu peux désactiver le calcul et les évènements

Sub BulkData()
  Dim I As Long
  Dim ShL As Worksheet
  Dim Cel As Range
  
  ' Désactiver les recalculs
  Application.Calculation = xlCalculationManual
  ' Désactiver le déclenchement des évènements
  Application.EnableEvents = False
  Set ShL = Sheets("Sheet2")
  With Sheets("BULK EQPT")
    For I = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      Set Cel = ShL.Columns("A:A").Find(.Range("D" & I), LookIn:=xlValues, Lookat:=xlWhole)
      If Not Cel Is Nothing Then
        .Range("E" & I) = ShL.Range("B" & Cel.Row)
        .Range("F" & I) = ShL.Range("C" & Cel.Row)
        .Range("G" & I) = ShL.Range("D" & Cel.Row)
        .Range("H" & I) = ShL.Range("E" & Cel.Row)
        .Range("I" & I) = ShL.Range("F" & Cel.Row)
        .Range("J" & I) = ShL.Range("G" & Cel.Row)
        .Range("K" & I) = ShL.Range("H" & Cel.Row)
        .Range("L" & I) = ShL.Range("I" & Cel.Row)
        .Range("M" & I) = ShL.Range("J" & Cel.Row)
        .Range("N" & I) = ShL.Range("K" & Cel.Row)
        .Range("O" & I) = ShL.Range("L" & Cel.Row)
        .Range("P" & I) = ShL.Range("M" & Cel.Row)
        .Range("Q" & I) = ShL.Range("N" & Cel.Row)
        .Range("R" & I) = ShL.Range("O" & Cel.Row)
      End If
    Next I
  End With
  ' Activer les recalculs
  Application.Calculation = xlCalculationAutomatic
  ' Activer le déclenchement des évènements
  Application.EnableEvents = True
End Sub

A+

 

[DRILL]

Re : Macro de remplissage trop lourde

Bonjour Bruno,

Je vais essayer ca.
De mon cote j'ai refait plusieurs manipes et par je ne sais quel miracle les 40.000 lignes sont passes en 4 mn.
J'ai utiliser la macro (identique a celle du fichier joint) d'un autre classeur et hop....
Est-ce que le fait qu'elle ne soit pas ratachee au fichier evite les recalcules??

J'essaye et te tiens au courant.. encore merci.

Drill... deja 10hrs de taf dans les pates... plus que 3.. vivement mardi les vacances.

 

[DRILL]

Re : Macro de remplissage trop lourde

Bruno,

Grand merci a toi, 2 mn montre en main... grace a cette petite astuce je vais pouvoir modifier une autre macro qui a pris 17heures a aboutir... le meme topo mais le recoupement se fait sur 6 fichiers de 13 a 20.000 lignes chaques.
Je vais finir gaga avec ces data.

@+
Drill

 

[flyonets44]

Re : Macro de remplissage trop lourde

Bonjour
tu peux aussi rajouter en début de macro
Application.screenupdating= false
au lieu d'écrire une à une les valeurs trouvées
tu peux également charger ces valeurs dans un tableau
puis renvoyer une seule fois ce tablo dans la feuille de destination
Cordialement
Flyonets

 

[Bebere]

Re : Macro de remplissage trop lourde

bonjour Drill,Flyonets,Bruno
le tout regrouper

Sub BulkData()
    Dim L As Long, Tbl As Variant
    Dim Cel As Range
    Dim C As Integer

    With Application
        ' Désactiver les recalculs
        .Calculation = xlCalculationManual
        ' Désactiver le déclenchement des évènements
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    With Sheets("BULK EQPT")
        Tbl = .Range("D2:R" & .Range("D65536").End(xlUp).Row)
    End With

    With Worksheets("Sheet2")
        For L = 1 To UBound(Tbl, 1)
            Set Cel = .Columns("A:A").Find(Tbl(L, 1), LookIn:=xlValues, Lookat:=xlWhole)
            If Not Cel Is Nothing Then
                For C = 2 To UBound(Tbl, 2)
                    Select Case C
                    Case 4
                        Tbl(L, C) = .Cells(Cel.Row, C) & "*" 'pour éviter changement en date
                    Case Else
                        Tbl(L, C) = .Cells(Cel.Row, C)
                    End Select
                Next
            End If
        Next L
    End With

    With Sheets("BULK EQPT")
        .Range("D2").Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl
    End With

    With Application
        ' Activer les recalculs
        .Calculation = xlCalculationAutomatic
        ' Activer le déclenchement des évènements
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

à bientôt