Appliquer tri sur tableau avec une macro VBA

Bonjour a tous,

Je viens vers vous parce que je bloque sur mon code.

J'ai un tableau que l'utilisateur va remplir sur la feuille "carloric value".

Le début du code, qui fonctionne, consiste en copier a la modificationce tableau de la feuille "carloric value" sur une feuille appelé "Europe", pour ensuite le completer avce d'autre donnée puisée dans la feuille data et ensuitre appliqué des tris dessus. Je bloque sur l'application de tris.

Voici mon code

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Dim Ingredients As Range
Dim IngredientLabel As Range

Set Ingredients = Sheets("caloric Value").Range("Ingredient_percent_eu")
Set IngredientLabel = Sheets("Europe").Range("ingredient_label_eu")

If Not Application.Intersect(Ingredients, Range(Target.Address)) Is Nothing Then

Ingredients.Copy

IngredientLabel.Value = Sheets("caloric Value").Range("Ingredient_percent_eu").Value

Application.CutCopyMode = False

    ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort.SortFields. _
        Add Key:=Range("Tableau10[statut]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort.SortFields. _
        Add Key:=Range("Tableau10[%]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort.SortFields. _
        Add Key:=Range("Tableau10[Label EU]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

End If

End Sub

Je souhaite applique un tris a multiple niveau.

Niveau 1: colonne "Statut", tris de Z à A

Niveau 2:colonne "%", tris par ordre decroissant

Niveau 3:colonne "Label EU", tris de A à Z

Visiblement, ya quelque chose que j'ai mal fait dans la paretie tris du tableau sur la page "Europe" car j'ai un message de bug

Sur le bout de code suivant

ActiveWorkbook.Worksheets("Europe").ListObjects("Tableau10").Sort.SortFields. _
        Add Key:=Range("Tableau10[statut]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal

Je vous remercie par avance pour votre aide

Voici mon fichier

Bastien

Bonjour

Modifiez cette partie de code

With Worksheets("Europe").ListObjects("Tableau10").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[status]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[%]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[Label EU]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

Cordfialement

Bonjour,

Merci pour votre aide

J'ai appliqué la modif proposée mais il semblerait que ça bloque toujours, il semblerait que ce soit toujours au même endroit :-(

Merci para avance pour votre aide

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Dim Ingredients As Range
Dim IngredientLabel As Range

Set Ingredients = Sheets("caloric Value").Range("Ingredient_percent_eu")
Set IngredientLabel = Sheets("Europe").Range("ingredient_label_eu")

If Not Application.Intersect(Ingredients, Range(Target.Address)) Is Nothing Then

Ingredients.Copy

IngredientLabel.Value = Sheets("caloric Value").Range("Ingredient_percent_eu").Value

Application.CutCopyMode = False

With Worksheets("Europe").ListObjects("Tableau10").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[status]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[%]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[Label EU]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

End If

End Sub

Bonjour

Cela fonctionne bien chez moi pourtant.

Ce sera plus simple si je vous renvoie votre fichier avec le code proposé. J'ai aussi inhibé quelques lignes qui ne servent pas

Cordialement

Bonjour,

Peut-être est-ce lié à un nom mal orthographié (je n'ai pas ouvert les fichiers) parce que je vois statut et status suivant les codes. Sinon, pouvez-vous essayer ainsi :

With Worksheets("Europe").ListObjects("Tableau10").Sort
    with .SortFields
        .Clear
        .Add Key:=Worksheets("Europe").Range("Tableau10[status]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Add Key:=Worksheets("Europe").Range("Tableau10[%]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Add Key:=Worksheets("Europe").Range("Tableau10[Label EU]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    end with
    .setrange range("Tableau10")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

'OU BIEN

With Worksheets("Europe").range("Tableau10").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[status]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[%]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Worksheets("Europe").Range("Tableau10[Label EU]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

En restant attentif au paramètre Header (qu'il faudra peut-être passer sur xlno)

Cdlt,

Dan a écrit :

Bonjour

Cela fonctionne bien chez moi pourtant.

Ce sera plus simple si je vous renvoie votre fichier avec le code proposé. J'ai aussi inhibé quelques lignes qui ne servent pas

Cordialement

Hello

Merci beaucoup pour votre aide et les sumplification.

ça fonctionne très bien.

Bonne semaine a tous

Bastien

Bonjour

Cordialement