Option Explicit
Sub ListDeCourse()
Dim Ws As Worksheet, WsList As Worksheet
Dim RngPlage As Range, CellPlage As Range
Dim ColElements As Collection, Item As Variant
Dim L As Integer
Set Ws = ThisWorkbook.Worksheets("Menu")
Set WsList = ThisWorkbook.Worksheets("Listes_course")
Set RngPlage = Ws.Range("Elements") '<<<<< Plage Nommée sur tableau Menu à peaufiner car là c'est le bordel !!!
Set ColElements = New Collection
For Each CellPlage In RngPlage
On Error Resume Next
ColElements.Add CellPlage.Value, CellPlage.Value
On Error GoTo 0
Next CellPlage
For Each Item In ColElements
L = WsList.Range("A500").End(xlUp).Row + 1
WsList.Range("A" & L) = Item
For Each CellPlage In RngPlage
If Item = CellPlage.Value Then
WsList.Range("B" & L) = WsList.Range("B" & L) + 1
End If
Next CellPlage
Next Item
End Sub