XL 2016 Extraction x fois

[patoq]

Bonjour le forum,

J'aimerais pouvoir accélérer une macro qui fonctionne mais devient lente sur une grande plage de données.
Dans le fichier joint, j'extrait 6 fois chaque code ( colonne I de la feuille Budget) dans l'onglet STJ .
J'ai mis une formule en colonne L et utilise un select case dessus pour ramener une identité unique.

Tout fonctionne à merveille mais la macro devient lente si le tableau source grossit.

Je pense que la macro est largement optimisable en passant par des tableaux, mais je n'est pas les compétences requises pour adapter mon code.

Merci de votre aide

Patrice

 

[Staple1600]

Bonsoir le fil, le forum

En attendant (non pas Godot) mais les tableaux
Une macro qui fait le job

Sub XFois()
Dim x As Long, l As Long
With Sheets("Budget")
    .Range("$A$1:$L$4499").AutoFilter Field:=12, Criteria1:="<>"
    .AutoFilter.Range.Columns(9).SpecialCells(xlCellTypeVisible).Copy Sheets("STJ").Range("A1")
    .ShowAllData
End With
Application.ScreenUpdating = False
With Sheets("STJ")
l = .Cells(Rows.Count, 1).End(xlUp).Row + 5
    For x = .Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    .Rows(x + 1).Resize(6 - 1).Insert
    .Rows(x).Resize(6).FillDown
   Next x
End With
End Sub

 

[Staple1600]

Bonjour le fil, le forum

Avec un petit bout de tableau c'est un peu plus rapide

Sub XFoisBis()
Dim t As Variant
With Sheets("Budget")
    .Range("$A$1:$L$4499").AutoFilter Field:=12, Criteria1:="<>"
    .AutoFilter.Range.Columns(9).SpecialCells(12).Copy Sheets("STJ").Range("A1")
    .ShowAllData
    .AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.ScreenUpdating = False
With Sheets("STJ")
    t = .UsedRange: lig = 2: Nx = 5
    .Cells.ClearContents: .[A1] = "CODE ARTICLE"
        For i = 2 To UBound(t, 1)
        data = t(i, 1)
        .Range("A" & lig & ":A" & (lig + Nx)) = data
        lig = lig + Nx + 1
        Next
End With
End Sub

En attendant, la version All Array inclusive
(Mais pour cela, je laisse la place à mes petits camarades de jeux)

 

[job75]

Bonjour patoq, JM, le forum,

Sub Extract()
Dim nfois, t, resu(), d As Object, i&, x, j, n&
nfois = 6 'modifiable
t = Sheets("Budget").[A1].CurrentRegion.Columns(9).Offset(1).Resize(, 2) 'tableau, plus rapide, au moins 2 éléments
ReDim resu(1 To nfois * UBound(t), 1 To 1) 'tableau pour le résultat, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t) - 1
    x = t(i, 1)
    If x <> "" And Not d.exists(x) Then
        d(x) = ""
        For j = 1 To nfois
            resu(n + j, 1) = x
        Next
        n = n + nfois
    End If
Next
'---restitution---
With Sheets("STJ").[A13] 'à adapter éventuellement
    .Resize(n + 1) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
End With
With Sheets("STJ").UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Bonne journée.

 

[job75]

Re,

J'ai corrigé la macro précédente pour éviter un bug (sur la restitution) quand on vide la feuille "Budget".

A+

 

[patoq]

Bonjour le forum, Job, JM,

Vos 2 macros fonctionne bien mais toujours 30 secondes pour extraire.
Merci quand même pour votre aide

Patrice

 

[job75]

Re,

Vos 2 macros fonctionne bien mais toujours 30 secondes pour extraire.

Alors vous n'avez pas testé, ma macro du post #4 s'exécute chez moi en 0,07 seconde, c'est instantané.
A+

 

[patoq]

Re,

Ce n'est pas sympa Job , j'ai testé plein de fois, et votre macro est tres rapide, c'est le recalcul des formules après qui prenait tout ce temps. Encore désolé.

Merci de votre aide
A +