XL 2013 VBA / Extraction des 10 plus petites valeurs d'un tableau structuré

[PMG]

Bonjour le forum,

J'avance dans mon code (SUB EXTRACTION) mais je reste bloqué sur la partie de restitutions des données:

J'ai un tableau structuré de 50 lignes et 9 colonnes (tableau fixe).

1/ Conditions (SUB TRANSFERT) = OK RÉSOLU

2/ Si "OK", extraction seulement des valeurs <= à 10 de la colonne 9. Elles sont calculées avec un ordre de priorité et il n'y a jamais de doublons.
3/ Copie des lignes correspondantes aux valeurs trouvées (mais seulement en partie et dans l'ordre des colonne 9,2, 3, 4) dans un autre tableau ("P11").

4/ Effacement des lignes extraites du "Tableau1". (SUB RESET) RÉSOLU

Pourriez-vous m'aider à compléter le code de (SUB EXTRACTION) svp?
Merci bcp par avance.
PMG
A+

 

[Dudu2]

Bonjour,

Ça ?

'-------------------------------------------------------------
'Extraction des 10 premiers éléments du Tableau1 en tableau P6
'-------------------------------------------------------------
Sub Extraction()
    Dim i As Integer

    'Inhibe l'affichage
    Application.ScreenUpdating = False

    'Tri du Tableau1 sur la colonne Rang
    ActiveSheet.Range("Tableau1").Sort key1:=ActiveSheet.Range("Tableau1[Colonne9]"), Header:=xlNo, Order1:=xlAscending

    'Pour les éventuels 10 premiers éléments du Tableau1
    For i = 1 To 10
        'Remise à blanc de la ligne du tableau P6
        ActiveSheet.Range("P6").Offset(i - 1, 0).Resize(1, 4).ClearContents
    
        'Si le Tableau1 a au moins i lignes
        If ActiveSheet.Range("Tableau1").Rows.Count >= i Then
        
            'Si le Rang est non nul
            If ActiveSheet.Range("Tableau1[Colonne9]").Cells(i).Value > 0 Then
        
                'Valoriser le Rang dans la ligne du tableau P6
                ActiveSheet.Range("P6").Offset(i - 1, 0).Value = i
            
                'Copier 3 cellules à partir de la 3ème du Tableau1 dans la ligne du tableau P6
                ActiveSheet.Range("Tableau1").Rows(i).Cells(3).Resize(1, 3).Copy _
                    Destination:=ActiveSheet.Range("P6").Offset(i - 1, 1)
            End If
        End If
    Next i

    'Tri du Tableau1 sur la colonne Date d'entrée
    Range("Tableau1").Sort key1:=Range("Tableau1" & "[Colonne2]"), Header:=xlNo, Order1:=xlAscending

    'Désinhibe l'affichage
    Application.ScreenUpdating = True

    MsgBox "Extraction terminée !"
End Sub

 

[PMG]

Bonjour, Dudu 2, le forum,

Merci bcp Dudu2 je me mélange les pinceaux à chaque fois! C'est exactement ce que je cherchais à faire.

Si je veux copier et coller les resultats dans destination (PasteSpecial Paste:=xlPasteValues) comment l’intégrer au code?

Merci infiniment!
PMG
A+

 

[Dudu2]

'Copier 3 cellules à partir de la 3ème du Tableau1 dans la ligne du tableau P6
ActiveSheet.Range("Tableau1").Rows(i).Cells(3).Resize(1, 3).Copy
ActiveSheet.Range("P6").Offset(i - 1, 1).PasteSpecial Paste:=xlPasteValues

A la fin du Sub tu peux éventuellement faire un ActiveSheet.[A1].Select si tu ne veux pas voir la dernière sélection du PasteSpecial.

 

[PMG]

J'avais laissé Destination:= , c'était tout simple!
Merci à toi, ton code va ma faire progresser!
A+