[VBA] faire un top 10

Bonjour à tous,

J'aimerai faire un top 10 en séléctionnant des données bien précies dans un tableau avec des critères.

J'ai fait un exemple simplifié de ce que je souhaite

1) Il faut dans un premiere étape faire comprendre au tableau que la colonne fleur doit prendre uniquement les données de la case K4

2) Qu'il faut trier du plus grand au plus petit avec la case K5

3) et que le nombre de ligne à copier est le nombre de la case K6 (ce nombre ne dépassera jamais 20 ) et seras à coller autre part.

Les données du tableaux doivent être copié dans un autre audroits d'ou le VBA.

En gros l'étape 1 et 2 se font dans le tableau et l'étape 3 se fait par un copier coller mais le nombre de ligne collé doit être égale à la case K6

Je ne voix pas du tout comment faire ,

J'ai essaye le code suivant pour l'étape 1 mais ca ne fonctionne pas

 vfil  = Range("K4").Value
  ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=1, Criteria1:= _
CurrentPage = vfil

Voila , merci de m'avoir lu et si je n'ai pas été assez précis n'hésitez pas a me le dire

Bonjour,

simple question ...

un TCD ne e convient pas ?

P.

Bonjour Patrick et merci de ta réponse.

J'ai déja pensé au TCD mais je ne pense pas que cela plus simple avec ce que je veux faire. La difficulté sera la même ( je pense )

Bonjour,

Une proposition à étudier en long et en large.

A te relire.

Bonne fêtes de fin d'année.

Cdlt.

Option Explicit
Dim lo As ListObject

Private Sub Worksheet_Activate()

    Me.[A2:C2].ClearContents

    Set lo = Me.ListObjects(1)

    With lo
        If .ShowAutoFilter Then
            .AutoFilter.ShowAllData
            .ShowAutoFilter = False
        End If
    End With

    Set lo = Nothing

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim rng As Range
Dim lTop As Long, lRowsInTable As Long, lRow As Long

    If Target.Address = "$A$2" Then

        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With

        Set lo = Me.ListObjects(1)
        Set ws = ActiveWorkbook.Worksheets("Filtre")
        lTop = Me.Cells(2, 3)

        If lo.ShowAutoFilter Then
            lo.AutoFilter.ShowAllData
        Else
            lo.ShowAutoFilter = True
        End If

        lo.Range.AutoFilter Field:=1, Criteria1:=Target.Value
        If Not IsEmpty(Me.Cells(2, 2)) Then
            With lo.Sort
                .SortFields.Add _
                        lo.ListColumns(Me.Cells(2, 2).Text).DataBodyRange, _
                        xlSortOnValues, _
                        xlDescending
                .Apply
                .SortFields.Clear
            End With
        End If

        With ws.ListObjects(1)
            If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
            lRow = 5
        End With

        Set rng = lo.AutoFilter.Range
        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy

        With ws
            .Cells(lRow, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            lRowsInTable = .ListObjects(1).ListRows.Count
            If lTop > 0 And lTop <= lRowsInTable Then
                For lRow = lRowsInTable To lTop + 1 Step -1
                    .ListObjects(1).ListRows(lRow).Delete
                Next lRow
            End If
            .Activate
            .Cells(1).Select
        End With

    End If

    Application.EnableEvents = True

    Set rng = Nothing
    Set lo = Nothing
    Set ws = Nothing

End Sub

Bonjour Jean-Eric

Ta solution est parfaite, j'en suis même impressionné

C'est même mieux que ce que j'imaginais.

Maintenant , il n'y a plus qu'a l'adapter sur un fichier un peu plus complexe mais je pense que ça devrais le faire mais il se peut que je te pose des questions.

Merci beaucoup!

Bonne journée et bonnes fêtes de fin d'années à vous aussi

Re,

Tu reviens quand tu veux.

As-tu besoin que je commente le code VBA?

Cdlt.

Oui je veux bien

J'ai regardé le programme et quelque chose m'intrigue : il n'y pas le nom des tableaux (tblDonnées et tblFiltre) ? Comment avez vous fait ?

Jean-Eric a écrit :

Re,

Tu reviens quand tu veux.

As-tu besoin que je commente le code VBA?

Cdlt.

Chouette code et belle proposition, Jean Eric, de commenter c'est toujours utile

Patrick

Bonjour,

Comme proposé, je renvoie le fichier avec le code commenté.

Si je ne suis pas clair dans mes explications, je suis à votre disposition.

Bonnes fêtes de fin d'année.

Cdlt.

Private Sub Workbook_Open()
    ' A l'ouverture du fichier, la feuille Donnees est activee
    ' La cellule A2 est selectionnee
    Application.Goto Worksheets("Données").Cells(2, 1)

End Sub

' Je n'ai pas cree de gestion d'erreur dans cet exemple.
' En case de problème, voir modHELP et lancer la procedure HELP
Option Explicit
' Declaration variables niveau module
Dim lo As ListObject

Private Sub Worksheet_Activate()
    ' Feuille Donnees
    ' A l'activation de la feuille, on efface le contenu des cellules A2, B2 et C2
    ' Me = ActiveSheet
    Me.[A2:C2].ClearContents
    ' On initialise la variable tableau (tblDonnees) de la feuille de calcul
    ' Voir gestionnaire de noms et copie d'ecran dans la feuille Listes
    ' Pas besoin de nommer le tableau car il est unique dans la feuille de calcul
    Set lo = Me.ListObjects(1)

    With lo
        ' Si le filtre automatique est affiché
        If .ShowAutoFilter Then
            ' On affiche toutes les données
            .AutoFilter.ShowAllData
            ' On désactive le filtre automatique
            .ShowAutoFilter = False
        End If
    End With
    ' On reinitialise la variable tableau (on vide la mémoire)
    Set lo = Nothing

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim rng As Range
Dim lTop As Long, lRowsInTable As Long, lRow As Long
    ' La procédure est executee au changement de valeur de la cellule A2
    ' Dans cet exemple, cela signifie que les cellules B2 (Tri) et C2 (Top) soient documentees
    ' (en fonction des résultats que l'on souhaite)
    If Target.Address = "$A$2" Then
        ' Optimisation procédure
        With Application
            ' Necessaire pour interdire l'evenement Worksheet_Activate
            .EnableEvents = False
            ' Affichage
            .ScreenUpdating = False
        End With
        ' Me = ActiveSheet
        ' On initialise la variable tableau (tblDonnees) de la feuille Données
        Set lo = Me.ListObjects(1)
        ' On initialise la variable worksheet
        Set ws = ActiveWorkbook.Worksheets("Filtre")
        ' Valeur du Top souhaité (voir feuille Listes)
        lTop = Me.Cells(2, 3)

        If lo.ShowAutoFilter Then
            lo.AutoFilter.ShowAllData
        Else
            lo.ShowAutoFilter = True
        End If
        ' lo.range = integralite du tableau avec en-têtes de colonnes
        ' Le filtre est effectué sur la colonne 1 du tableau et le critère est la valeur de la cellule $A$2
        lo.Range.AutoFilter Field:=1, Criteria1:=Target.Value
        ' Si la cellule B2 (Tri) est non vide
        If Not IsEmpty(Me.Cells(2, 2)) Then
            ' On trie le tableau en fonction de la valeur de B2
            ' DataBodyRange = tableau sans les en-têtes de colonne (valeurs)
            With lo.Sort
                .SortFields.Add _
                        lo.ListColumns(Me.Cells(2, 2).Text).DataBodyRange, _
                        xlSortOnValues, _
                        xlDescending
                .Apply
                .SortFields.Clear
            End With
        End If

        ' Avec la feuille Filtre et son tableau (tblFiltre)
        With ws.ListObjects(1)
           ' Si la plage des valeurs est non vide, on réinitialise le tableau
           ' DataBodyRange.delete conserve les formules et le format des cellules!
           ' Pas besoin de reprendre les formules existantes et de devoir modifier le format des cellules
            If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
            lRow = 5
        End With
        ' On initialise la plage de valeurs filtrées à copier
        ' La copie s'effectue sans les en-têtes de colonnes
        Set rng = lo.AutoFilter.Range
        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        ' Avec la feuille Filtre
        With ws
            ' On colle la plage filtrée
            .Cells(lRow, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            ' On calcule le nombre de lignes du tableau
            lRowsInTable = .ListObjects(1).ListRows.Count
            ' si la valeur Top est supérieure à zéro et inferieure ou egale au nombre de lignes du tableau,
            ' on supprime les lignes superflues
            ' FAIRE ATTENTION : Listobjects(1).DataBodyRange.rows.count <> Listobjects(1).ListRows.Count
            If lTop > 0 And lTop <= lRowsInTable Then
                For lRow = lRowsInTable To lTop + 1 Step -1
                    .ListObjects(1).ListRows(lRow).Delete
                Next lRow
            End If
            ' On active la feuille Filtre
            .Activate
            ' On sélectionne la cellule A1
            .Cells(1).Select
        End With

    End If
    ' On autorise l'evenement Worksheet_Activate
    Application.EnableEvents = True
    ' On reinitialise les variables (on vide la mémoire)
    Set rng = Nothing
    Set lo = Nothing
    Set ws = Nothing

End Sub

Public Sub HELP()
    ' A executer en case de probleme...
    Application.EnableEvents = True

End Sub