XL 2010 Formule prend beaucoup de temps pour s activer

IMRANE

XLDnaute Occasionnel
Bonjour le forum
Svp j ai une formule qui prend presque une minute pour s activer je sais pas a cause de quoi
si quelqu un peut m aider a résoudre ce problème j ai mis un fichier excel joint pour éclairssir le cas
et Merci le forum
 

Pièces jointes

  • 01.Sic Asmaa 2022 - Copie.xlsm
    918.6 KB · Affichages: 8

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Imrane,
Un essai en PJ, je suis passé par deux arrays ce qui est infiniment plus rapide.
A tester.

NB: Après mesures sur mon PC, je passe de 31s à 0.25s soit 124 fois plus rapide.
Regardez comment marche les arrays, c'est sympa.
 

Pièces jointes

  • 01.Sic Asmaa 2022 - Copie.xlsm
    883.2 KB · Affichages: 5
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Je l'ai écrit donc je poste :
VB:
Option Explicit
Sub Copier()
   Dim TSrc(), TCbl(), LSrc As Long, LCbl As Long, C As Integer
   TSrc = Feuil2.ListObjects("T_LIVRAISONS_Livraisons").DataBodyRange.Value
   ReDim TCbl(1 To UBound(TSrc, 1), 1 To 8)
   For LSrc = 1 To UBound(TSrc)
      If TSrc(LSrc, 24) Like "COMMANDE*" Then
         LCbl = LCbl + 1
         For C = 1 To 7: TCbl(LCbl, C) = TSrc(LSrc, C): Next C
         TCbl(LCbl, 8) = TSrc(LSrc, 24)
         End If
      Next LSrc
   TableauRetaillé(Feuil13.ListObjects("Tableau16"), LCbl) = TCbl
   End Sub
Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long, TVals())
   Dim Trop As Long, CMax As Long, TFml(), F As Long
   If LMax = 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 And LMax + Trop > 1 Then
      LOt.ListRows(LMax + Trop).Range.Resize(-Trop).Insert xlShiftDown, xlFormatFromLeftOrAbove
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .Formula2R1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.Formula2R1C1 = TFml(F)
      Next F
   End Property
 

IMRANE

XLDnaute Occasionnel
Bonjour.
Je l'ai écrit donc je poste :
VB:
Option Explicit
Sub Copier()
   Dim TSrc(), TCbl(), LSrc As Long, LCbl As Long, C As Integer
   TSrc = Feuil2.ListObjects("T_LIVRAISONS_Livraisons").DataBodyRange.Value
   ReDim TCbl(1 To UBound(TSrc, 1), 1 To 8)
   For LSrc = 1 To UBound(TSrc)
      If TSrc(LSrc, 24) Like "COMMANDE*" Then
         LCbl = LCbl + 1
         For C = 1 To 7: TCbl(LCbl, C) = TSrc(LSrc, C): Next C
         TCbl(LCbl, 8) = TSrc(LSrc, 24)
         End If
      Next LSrc
   TableauRetaillé(Feuil13.ListObjects("Tableau16"), LCbl) = TCbl
   End Sub
Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long, TVals())
   Dim Trop As Long, CMax As Long, TFml(), F As Long
   If LMax = 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 And LMax + Trop > 1 Then
      LOt.ListRows(LMax + Trop).Range.Resize(-Trop).Insert xlShiftDown, xlFormatFromLeftOrAbove
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .Formula2R1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.Formula2R1C1 = TFml(F)
      Next F
   End Property
[QUOTE="Dranreb, post: 20480214, member: 171206"]
Bonjour.
Je l'ai écrit donc je poste :
[CODE=vb]Option Explicit
Sub Copier()
   Dim TSrc(), TCbl(), LSrc As Long, LCbl As Long, C As Integer
   TSrc = Feuil2.ListObjects("T_LIVRAISONS_Livraisons").DataBodyRange.Value
   ReDim TCbl(1 To UBound(TSrc, 1), 1 To 8)
   For LSrc = 1 To UBound(TSrc)
      If TSrc(LSrc, 24) Like "COMMANDE*" Then
         LCbl = LCbl + 1
         For C = 1 To 7: TCbl(LCbl, C) = TSrc(LSrc, C): Next C
         TCbl(LCbl, 8) = TSrc(LSrc, 24)
         End If
      Next LSrc
   TableauRetaillé(Feuil13.ListObjects("Tableau16"), LCbl) = TCbl
   End Sub
Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long, TVals())
   Dim Trop As Long, CMax As Long, TFml(), F As Long
   If LMax = 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 And LMax + Trop > 1 Then
      LOt.ListRows(LMax + Trop).Range.Resize(-Trop).Insert xlShiftDown, xlFormatFromLeftOrAbove
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .Formula2R1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.Formula2R1C1 = TFml(F)
      Next F
   End Property
Bonjour Dranreb Merci pour ton aide precieux
[/QUOTE]
La fonction est maintenant tres rapide Merci une autre fois
 

Discussions similaires