XL 2010 Formule prend beaucoup de temps pour s activer

sylvanu à dit:

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.

Cliquez pour agrandir...

Dranreb à dit:

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

Cliquez pour agrandir...