XL 2016 Méthode rapide pour mettre cellules dans variable tableau

[Compte Supprimé 979]

Bonjour à toutes et à tous,

Qui pourrait me donner une méthode rapide pour le code pour mettre des cellules dans une variable tableau

Situation :
- J'ai un classeur de DA (Demande d'Achats) qui contient 12.500 lignes
- Sur la feuille "DA" on saisi en colonne H les quantités souhaitées de matériel

Objectif :
- Mettre plusieurs cellule de la ligne contenant une Qt dans une variable tableau

Sachant que le fichier contient plus de 12.000 lignes
- je vais comptabiliser le nombre de lignes dont Qt <> 0

Je pensais faire une boucle et mémoriser chaque ligne dont Qt <>0 et sortir de la boucle si NbLignesQt est atteint
Mais n'y a t'il pas une solution plus rapide ?

Un fichier test qui va bien pour quelques lignes... mais pour plus de 10.000

Par avance merci de votre aide

 

[TooFatBoy]

Bonjour,

Je n'ai pas testé, mais est-ce qu'on ne pourrait pas utiliser une plage nommée ?

 

[Cousinhub]

Hello Bruno,
4,6 centièmes de secondes sur >14 000 lignes, avec 2500 renvois de données, si cela t'intéresse...

Sub Bruno()
Dim Tbl
Dim Tbl2()
Dim I As Long, J As Long
Dim K As Byte
T = Timer
With Sheets("DA")
    Tbl = .Range("A7:Q" & .Cells(Rows.Count, "F").End(xlUp).Row)
    For I = LBound(Tbl) To UBound(Tbl)
        If Tbl(I, 8) <> 0 Then
            ReDim Preserve Tbl2(3, J)
            For K = 0 To 3
                Tbl2(K, J) = Tbl(I, 5 + K)
            Next K
            J = J + 1
        End If
    Next I
End With
Tbl2 = Application.Transpose(Tbl2)
Sheets("Résultat").Range("K1").Resize(UBound(Tbl2), 4).Value = Tbl2
MsgBox Timer - T
End Sub

Bonne journée

 

[Efgé]

Bonjour à tous
Je pense que le redim preserve est assez long.
Je propose en repartant du code de @ChTi160 avec la boucle de @bhbh

Sub Test_3()
  Dim Sht As Worksheet
  Dim dLig As Long, Lig As Long, i As Long
  Dim Inc As Long, NbQt As Long
  Dim Col As Integer
  Dim dCol As Byte
  Dim Tablo
  Set Sht = ThisWorkbook.Sheets("DA")
  Inc = 0
  dLig = Sht.Cells(Sht.Rows.Count, 6).End(xlUp).Row
  If dLig = 6 Then Exit Sub 'si plage de données vide on quitte
  dCol = Sht.Cells(4, Sht.Columns.Count).End(xlToLeft).Column
  Tablo = Sht.Range(Sht.Cells(7, 1), Sht.Cells(dLig, dCol))
  ' Pour chaque ligne du tableau
  For Lig = 1 To UBound(Tablo)
    If Tablo(Lig, 8) <> 0 Then
      ' Incrémenter le nombre de quantité
      Inc = Inc + 1
      For i = 1 To 4
        Tablo(Inc, i) = Tablo(Lig, i + 4)
        Next i
    End If
  Next Lig
     If Inc = 0 Then Exit Sub 'Si pas de retour On quitte
  ' Résultat

    Sheets("Résultat").Range("A1").Resize(Inc, 4) = Tablo
 
End Sub

Cordialement

 

[Cousinhub]

Re-,
@Efgé
Je viens de faire l'essai avec ton code, déjà, on obtient les mêmes résultats...
Et exactement le même temps... 0,046875 s
Bruno a le choix

 

[Efgé]

Re

Mais il ne faut pas à avoir à réutiliser le tableau Initial Lol

Dans ce cas, en début on place
TabloTravail = TabloInitial

Cordialement

 

[patricktoulon]

bonjour a tous
juste en passant et j'en sais rien si ça aura vraiment un effet
je vois des boucles for lig = 1.... de la ilgne 1 à X pour remplir
il est venue l'idée a personne de boucler non pas sur les lignes de la plage mais les lignes de la plage .voir meme filtrée provisoirement

il n'y a pas un truc a faire avec ca histoire de zapper plus vite les ligne vide ou = à zero ??

 

[patricktoulon]

du genre comme ça
j’espère que les commentaires suffiront

Sub test2()
    Dim p As Range, Pc As Range, tablo(), Lig&, A&, C&
    'on détermine la plage a copier E:H avec les ligne vide en "H"
    Set p = Sheets("DA").Range("E" & 7, Sheets("DA").Cells(Rows.Count, "H").End(xlUp))
    ' on determine la plage (colonne"H" avec uniquement les cellule pleines
    Set Pc = p.Columns(4).SpecialCells(xlCellTypeConstants)
    'le nombre de cellule pleines  de la colonne"H" sera donc le nombre de ligne  à  boucler
    nblig = Pc.Cells.Count
    ' on crée donc la variable tableau avec le nombre de ligne et 4  colonnes
    ReDim tablo(1 To nblig, 1 To 4)
    'MsgBox Pc.Cells.Count 'juste pour controler
    'ici on boucle donc sur (seulement les cells  de Pc (qui on un nombre  )
    For Each cel In Pc.Cells
        Lig = cel.Row    'on detrmine  donc la ligne de cette cells
        A = A + 1    'on incrémente  pour le tableau
        'on boucle sur les 4  colonnes
        For C = 1 To 4
            tablo(A, C) = Sheets("DA").Cells(Lig, C + 4)    'on inscrit les valeurs
        Next
    Next
    'on envoie tout ça dans le sheets("Résultat") en [A1]
    Sheets("Résultat").Range("A1").Resize(UBound(tablo), 4).Value = tablo
End Sub

 

[patricktoulon]

et j'en ai une autre encore plus surprenante si vous voulez

 

[Cousinhub]

Bonsoir,
Patrick, avec mon fichier test (>14000 lignes...)
0,10 à 0,12, soit 2 moins rapide...
J'ai également essayé avec un filtre élaboré, et je ne suis pas descendu sous les 0,055

 

[vgendron]

Hello

Sans redim, j'utilise souvent la méthode: j'efface les parties du tableau qui ne m'intérressent pas. et à la fin, je supprime les lignes vides..
mais.. jamais eu besoin de faire ca sur plus de 300 lignes.. donc;. temps d'execution..??

Sub test2()
Application.ScreenUpdating = False

Dim TabData() As Variant
Dim Fin As Long
Dim i, j As Long
With Sheets("DA")
    Fin = .UsedRange.Rows.Count
    TabData = .Range("A4:Q" & Fin).Value
End With
For i = LBound(TabData, 1) To UBound(TabData, 1)
    If TabData(i, 8) = "" Then
        For j = LBound(TabData, 2) To UBound(TabData, 2)
            TabData(i, j) = ""
        Next j
    End If
Next i

With Sheets("Résultat")
    .Range("A1").Resize(UBound(TabData, 1), UBound(TabData, 2)) = TabData
    .Range("A1").Resize(UBound(TabData, 1), UBound(TabData, 2)).Columns(8).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Union(.Columns("A:D"), .Columns("I:Q")).Delete
End With
Application.ScreenUpdating = True

End Sub

 

[Cousinhub]

Hello,
Les résultats sont bons.
Le temps : 1,62 (le .SpecialCells est très gourmand dès qu'il y a un nb conséquent de lignes)
Bonne soirée

 

[patricktoulon]

Bonsoir,
Patrick, avec mon fichier test (>14000 lignes...)
0,10 à 0,12, soit 2 moins rapide...
J'ai également essayé avec un filtre élaboré, et je ne suis pas descendu sous les 0,055

Bonjour @bhbh
oui c'est possible
après un simple autofilter et copie dans résultat devrait être plus rapide je pense

 

[Cousinhub]

Perso, je ne le pense pas, le filtre élaboré étant bien plus rapide...

 

[patricktoulon]

re
tiens j'ai pas tester sur 14 000 lignes mais bon

Sub test3()
    Dim Tbl
    Dim lignes()
    Dim I As Long, J As Long
    Dim K As Byte
    T = Timer
    With Sheets("DA")
        Tbl = .Range("A7:Q" & .Cells(Rows.Count, "F").End(xlUp).Row)
        For I = LBound(Tbl) To UBound(Tbl)
            If Tbl(I, 8) <> 0 Then a = a + 1: ReDim Preserve lignes(1 To a): lignes(a) = I
        Next I
    End With
    tabl = Application.Index(Tbl, Application.Transpose(lignes), Array(5, 6, 7, 8))

    Sheets("Résultat").Range("K1").Resize(UBound(tabl), 4).Value = tabl
    MsgBox Timer - T
End Sub