XL 2016 Gestion de liste de courses pour sejour de groupe

Private Sub Worksheet_Change(ByVal Target As Range)
    
     Select Case True
          Case Target.Address = [nom_Séjour].Address
               If IsEmpty([nb_Personnes]) Or IsEmpty([nb_Jours]) Then
                    MsgBox "Remplir le nombre de personnes et le nombre de jours avant de nommer le séjour."
                    Exit Sub
               End If
               Application.EnableEvents = False
               Txt = Target.Text
               If Not [contrôle_Nom_Séjour] Then  'Nom défini qui teste la validité de nom du séjour
                    Application.Undo
                    'vérifier la validité du nom de séjour (avant de créer la feuille)
                    Select Case True
                         Case Len(Txt) = 0 Or Len(Txt) > 24 '(31c -7c)
                              MsgBox Prompt:=Txt & Chr(10) & "Nombre de caractères incorrect !", Title:="-----Nom du séjour-----"
                         Case Else
                              MsgBox Prompt:=Txt & Chr(10) & "Caractère interdit !", Title:="-----Nom du séjour-----"
                    End Select
                    Application.EnableEvents = True: Exit Sub
               End If
              
               'Voir si un séjour du même nom existe déjà
               On Error Resume Next
               Set WSh = Nothing
               Set WSh = ThisWorkbook.Worksheets("Séjour " & Txt)
               On Error GoTo 0
               If Not WSh Is Nothing Then
                    Application.Undo
                    MsgBox Prompt:="Un séjour nommé" & Chr(10) & Chr(9) & """" & Txt & """" & Chr(10) & "existe déjà !", _
                           Title:="-----Nom du séjour-----"
                    Application.EnableEvents = True: Exit Sub
               End If
              
     End Select
     Application.EnableEvents = True
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    
     If Intersect(ActiveCell, [tb_Recettes]) Is Nothing Then Exit Sub
    
     typCol = Intersect(ActiveCell.EntireColumn, [tb_Recettes].ListObject.HeaderRowRange)
     If Not typCol Like "Ingrédient*" Then Exit Sub
    
     Cancel = True
     Set Cible = ActiveCell
    
     If Intersect([tb_Recettes[Type de plat]], Cible.EntireRow) = "" Then MsgBox "Renseigez d'abord le type de plat.": Exit Sub
     UsF_choix_Ingrédients.Show
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

     Dim dico As Object
     Set dico = CreateObject("Scripting.Dictionary")
     Lo = Me.ListObjects(1).Name
    
     If Target.CountLarge > 1 Or Intersect(Evaluate(Lo), Target) Is Nothing Then Exit Sub
    
     Plats = Evaluate(Lo & "[[Déjeuner]:[Dîner]]")     'colonnes Déjeuner et diner
     Recettes = [tb_Recettes]                          'tableau des recettes
    
     'composer un dictionnaire des ingrédients utilisés pour le séjour
     For i = 1 To UBound(Plats, 1): For j = 1 To UBound(Plats, 2) 'on parcourt tous les repas
          Plat = Plats(i, j)
          If Plat <> "" Then       'si le plat de ce repas est défini
               With WorksheetFunction
                    idx = .Match(Plat, .Index(Recettes, 0, 1), 0)     'type de plat pour lire la quantité/Pers pour les ingrédients
                    For h = 0 To 19     'pour chaque ingrédient possible
                         col = 3 + h * 3     'colonne ingrédient
                         ingrédient = Recettes(idx, col): unité = Recettes(idx, col + 2): qté = Recettes(idx, col + 1)
                         If ingrédient <> "" Then      'si cet ingrédient est défini en incrémenter la qté
                              'la clé du dico est la concaténation de l'ingrédient et de l'unité utilisée
                              dico(ingrédient & "¤" & unité) = dico(ingrédient & "¤" & unité) + qté
                         End If
                    Next
               End With
          End If
     Next j: Next i
    
     nb = dico.Count               'nb d'ingrédients trouvés
     Lo = Me.ListObjects(2).Name   'nom du tableau d'avitaillement
     Set LObj = Me.ListObjects(Lo)
    
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Evaluate(Lo).ClearContents         'RàZ du tableau d'avitaillement
    
     If nb > 0 Then
          nbPers = Me.[nb_Personnes]         'pour la quantité pour le nb de personnes
          tb1 = dico.keys: tb2 = dico.Items  'les infos du dico dans des tableaux,tb1 : les clés, tb2 les quantités
          ReDim ingrédients(1 To nb, 1 To 3) 'dimensionnement du tableau résultat (nb ingrédients; nom, qté, unité)
          
          For i = 1 To nb                    'remplissage du tableau
               Txt = Split(tb1(i - 1), "¤")  'découper la clé 0 : nom de l'ingrédient, 1 : unité utilisée
               ingrédients(i, 1) = Txt(0): ingrédients(i, 2) = Txt(1): ingrédients(i, 3) = tb2(i - 1) * nbPers
               If ingrédients(i, 2) = "pièce" Then ingrédients(i, 3) = WorksheetFunction.Ceiling(ingrédients(i, 3), 1)
          Next i
          'redimensionner le tableau structuré, et le remplir
          With LObj
               .Resize .Range.Resize(nb + 1)
               .DataBodyRange.Value = ingrédients
               With .Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=LObj.ListColumns(1).DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .Apply
               End With
          End With
     Else
          'tableau structuré vide
          With LObj
               .Resize .Range.Resize(2)
          End With
     End If
    
     Application.ScreenUpdating = True
     Application.EnableEvents = True
    
End Sub

Public Cible As Range

Sub Nouveau_Séjour()
    
     Dim WSh As Worksheet, Lo As ListObject, AdrRg$, Nom$, nbJours%, nbPersonnes%
    
     Nom = [nom_Séjour]
     nbJours = [nb_Jours]
     nbPersonnes = [nb_Personnes]
    
     If nbJours < 1 Or nbPersonnes < 1 Then
          MsgBox Prompt:="Remplissez d'abord le nombre de jours et le nombres de personnes !", Title:="Séjour """ & Nom & """": Exit Sub
     End If
      
     If Nom = "" Then
          MsgBox Prompt:="Attribuez d'abord un nom au séjour !", Title:="Séjour": Exit Sub
     End If
    
     sh_Modèle_Séjour.Copy After:=Sh_Accueil
     Set WSh = ThisWorkbook.Worksheets(Sh_Accueil.Index + 1)
     WSh.Name = "Séjour " & Nom
     WSh.Visible = True
    
     For Each Nm In WSh.Names
          Nm.Delete
     Next
     AdrRg = sh_Modèle_Séjour.Names("Nb_Personnes_à_bord").RefersToRange.Address
     WSh.Names.Add Name:="Nb_Personnes_à_bord", RefersTo:=WSh.Range(AdrRg)
     WSh.[Nb_Personnes_à_bord].Value = nbPersonnes
     WSh.Activate
     ActiveWindow.DisplayGridlines = False

     Nom_Tableau = "tb_" & Replace(Replace(Replace(Replace(Replace("Séjour " & Nom, "-", "_"), " ", "_"), "-", "¤"), "+", "¤"), """", "")
     Set Lo = WSh.ListObjects(1)
     Lo.Name = Nom_Tableau
     Lo.Resize Lo.Range.Resize(nbJours + 1)
     With Lo.ListColumns(1).DataBodyRange
          For i = 1 To nbJours
               .Cells(i) = i
          Next
     End With
    
     Nom_Tableau = "tb_" & Replace(Replace(Replace(Replace(Replace("Avitaillement " & Nom, "-", "_"), " ", "_"), "-", "¤"), "+", "¤"), """", "")
     Set Lo = WSh.ListObjects(2)
     Lo.Name = Nom_Tableau

     Application.EnableEvents = False: [nom_Séjour].ClearContents: Application.EnableEvents = True
End Sub