Alleger un code

Le 23/02/2020 à 15:14

Bonjour le Forum

j'aimerais savoir si y a moyen de verifier un code qui fonctionne très bien pour ce que je veux en faire, le doute que j'ai est qu'il me semble etre trop répétitif, est qu'une bonne âme pourrait y jeter un oeil, et me guider pour l(alléger si possible, sans changer les variable sinon je ne vais plus m'y retrouver.

je met le code si dessous et en telechargement pour qu'il soit plus lisible.

merci d'avance, Amicalement Domy

Sub Tab_Entrees()

'A faire :
'- Soit Nettoyer Le tableau de la page Critere
'- ou Creer different tableaupour les semaines ? venir (52 voir 53 pour l'an)...
'- Finaliser le remplissage du tableau Menu Semaine pour le soir, code pr?cedent OK
'- Verifier les Bouton menu soir et midi, pour qu'au d?marage la 'Coche_Rouge' apparait

'*********************EN PRIORITITE*****************************************
'- Optimiser le code pour ?viter les redondances des boucles similaires
'**************************************************************************
Col = 3
Ligne = 6
Ligne_Tab = 6
Cmpt_Jour = 0
I = 0
Mem_Ligne = 2
Mem_Col = 13
    If Actif = 0 Then
    MsgBox "- Veuillez definir si il faut prevoir un Menu du soir", vbInformation

    Exit Sub
    End If

    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

Creat_Tableaux

'======================================================================================
'                   Remplissage de la grille semaine pour les ENTREES
'=======================================================================================

' Controler la reprise du programme si arret d'Excel pour ne pas redemarer a z?ro la grille menu
' le faire en liaison avec la grille crit?res si pas vide
' et ?a sur chaque passage des boucles

If Sheets("Criteres").Cells(2, 13) <> "" Then GoTo Fin
'=======================================================================================
          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

A = UBound(Tab_BD_Entrees, 1)
'=========D?but de la Boucle et verifie si assez de plat ==============================

                    While Len(Range("I" & Actif)) = Lg

                        If Sheets("BD_Repas").Cells(2, 1) = Rep_Ligne - 2 Then 'Comptabilise les enregistrements jusqu'? la cellule 500
                                MsgBox "- il n'y a plus d'ENTREES de disponibles." & Chr(10) & Chr(10) _
                                & "- Veuillez passer par le menu pour remettre a Z?ro la Base (ENTREES)", vbInformation
                            GoTo Fin
                        End If
'=============================Chiffre aleatoire =======================================
DepAlea:
Nb_Alea = 0
    Randomize
'Nombre al?atoire entier entre 1 et 50 : pour commencer, ensuite ce regler sur la longueur de la table.
    Nb_Alea = Int(A * Rnd) + 1
    If Tab_BD_Entrees(Nb_Alea, 0) = 1 Then GoTo DepAlea                                 'Verifie que la ligne dn BD_Entr?es n'est pas deja choisi
    If Tab_BD_Entrees(Nb_Alea, 3) = "D?sactiv?" Then GoTo DepAlea                       'Colonne C ID_Plat " D?sactiv?

                    If Tab_BD_Entrees(Nb_Alea, 1) = 1 Then                              'Colonne C ID_Plat " ENTRE, ACompagnement etc ...
                            Cells(Ligne_Tab, Col) = Tab_BD_Entrees(Nb_Alea, 4)          'Entr?e dans la page Aff_Semaine

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Entrees(Nb_Alea, 4)       'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Entrees(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If

                            Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8      'sert a definir si les repas son inscris le midi et le soir
                            Tab_BD_Entrees(Nb_Alea, 0) = 1                              ' Change la valeur de la colonne en 1 Pour ne pas rechoisir ? nouveau le plat

                        Sheets("BD_Repas").Cells(Nb_Alea + 2, 1) = 1                    'Inscription dans la grille des MENUS
                                Mem_Col = Mem_Col + 1

                       End If
                Wend

                        'Sheets("Aff_Semaine").Range("B5").Select
Fin:
'======================================================================================
'                   Remplissage de la grille semaine pour des PLATS
'==================================a====================================================
If Sheets("Criteres").Cells(3, 13) <> "" Then GoTo Fin2
'======================================================================================
    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

Mem_Ligne = 3   'Position de la Ligne dans la page Criteres
Mem_Col = 13    'Position de la colonne dans la page Criteres
Ligne_Tab = 6
'=========D?but de la Boucle et verifie si assez de plat ==============================

          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

B = UBound(Tab_BD_Plats, 1)

                    While Len(Range("I" & Actif)) = Lg

                        If Sheets("BD_Repas").Cells(2, 9) = Rep_Ligne - 2 Then 'Comptabilise les enregistrements jusqu'? la cellule 500
                                MsgBox "- il n'y a plus de Plats de disponibles." & Chr(10) & Chr(10) _
                                & "- Veuillez passer par le menu pour remettre a Z?ro la Base (ENTREES)", vbInformation
                            GoTo Fin2
                        End If

'=============================Chiffre aleatoire =======================================
DepAlea2:
Nb_Alea = 0
    Randomize
'Nombre al?atoire entier entre 1 et 50 : pour commencer, ensuite ce regler sur la longueur de la table.
    Nb_Alea = Int(B * Rnd) + 1
    If Tab_BD_Plats(Nb_Alea, 0) = 1 Then GoTo DepAlea2                                 'Verifie que la ligne dn BD_Entr?es n'est pas deja choisi
    If Tab_BD_Plats(Nb_Alea, 3) = "D?sactiv?" Then GoTo DepAlea2                       'Colonne C ID_Plat " D?sactiv?

                    If Tab_BD_Plats(Nb_Alea, 1) = 2 Then                              'Colonne C ID_Plat " ENTRE, ACompagnement etc ...
                            Cells(Ligne_Tab, Col) = Tab_BD_Plats(Nb_Alea, 4)          'Entr?e dans la page Aff_Semaine

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Plats(Nb_Alea, 4)       'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Plats(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If
                            Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8      'sert a definir si les repas son inscris le midi et le soir
                            Tab_BD_Plats(Nb_Alea, 0) = 1                              ' Change la valeur de la colonne en 1 Pour ne pas rechoisir ? nouveau le plat

                        Sheets("BD_Repas").Cells(Nb_Alea + 2, 9) = 1                    'Inscription dans la grille des MENUS
                                Mem_Col = Mem_Col + 1

                       End If
                Wend
                        'Sheets("Aff_Semaine").Range("B5").Select
Fin2:
'======================================================================================
'                   Remplissage de la grille semaine pour les Accompagnements
'==================================a====================================================
If Sheets("Criteres").Cells(4, 13) <> "" Then GoTo Fin3
'=======================================================================================
    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

Mem_Ligne = 4   'Position de la Ligne dans la page Criteres
Mem_Col = 13    'Position de la colonne dans la page Criteres
Ligne_Tab = 6
'=========D?but de la Boucle et verifie si assez de plat ==============================

          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

C = UBound(Tab_BD_Accompagnement, 1)

                    While Len(Range("I" & Actif)) = Lg

                        If Sheets("BD_Repas").Cells(2, 17) = Rep_Ligne - 2 Then 'Comptabilise les enregistrements jusqu'? la cellule 500
                                MsgBox "- il n'y a plus d'Accompagnements de disponibles." & Chr(10) & Chr(10) _
                                & "- Veuillez passer par le menu pour remettre a Z?ro la Base (ENTREES)", vbInformation
                            GoTo Fin3
                        End If
'=============================Chiffre aleatoire =======================================
DepAlea3:
Nb_Alea = 0
    Randomize
'Nombre al?atoire entier entre 1 et 50 : pour commencer, ensuite ce regler sur la longueur de la table.
    Nb_Alea = Int(C * Rnd) + 1
    If Tab_BD_Accompagnement(Nb_Alea, 0) = 3 Then GoTo DepAlea3                                'Verifie que la ligne dn BD_Entr?es n'est pas deja choisi
    If Tab_BD_Accompagnement(Nb_Alea, 3) = "D?sactiv?" Then GoTo DepAlea3                      'Colonne C ID_Plat " D?sactiv?

                    If Tab_BD_Accompagnement(Nb_Alea, 1) = 3 Then                              'Colonne C ID_Plat " ENTRE, ACompagnement etc ...
                            Cells(Ligne_Tab, Col) = Tab_BD_Accompagnement(Nb_Alea, 4)          'Entr?e dans la page Aff_Semaine

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Accompagnement(Nb_Alea, 4)       'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Accompagnement(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If

                            Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8             'sert a definir si les repas son inscris le midi et le soir
                            Tab_BD_Accompagnement(Nb_Alea, 0) = 1                              ' Change la valeur de la colonne en 1 Pour ne pas rechoisir ? nouveau le plat

                        Sheets("BD_Repas").Cells(Nb_Alea + 2, 17) = 1                          'Inscription dans la grille des MENUS
                                Mem_Col = Mem_Col + 1

                       End If

                Wend
                        'Sheets("Aff_Semaine").Cells("B5").Select
Fin3:
'======================================================================================
'                   Remplissage de la grille semaine pour les Apres plats
'==================================a====================================================
If Sheets("Criteres").Cells(5, 13) <> "" Then GoTo Fin4
'=======================================================================================

    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

Mem_Ligne = 5   'Position de la Ligne dans la page Criteres
Mem_Col = 13    'Position de la colonne dans la page Criteres
Ligne_Tab = 6
'======================================================================================
          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

D = UBound(Tab_BD_Apres_Plat, 1)
'=========D?but de la Boucle et verifie si assez de plat ==============================

                    While Len(Range("I" & Actif)) = Lg

                        If Sheets("BD_Repas").Cells(2, 25) = Rep_Ligne - 2 Then 'Comptabilise les enregistrements jusqu'? la cellule 500
                                MsgBox "- il n'y a plus d'Apr?s Plats de disponibles." & Chr(10) & Chr(10) _
                                & "- Veuillez passer par le menu pour remettre a Z?ro la Base (ENTREES)", vbInformation
                            GoTo Fin4
                        End If
'=============================Chiffre aleatoire =======================================
DepAlea4:
Nb_Alea = 0
    Randomize
'Nombre al?atoire entier entre 1 et 50 : pour commencer, ensuite ce regler sur la longueur de la table.
    Nb_Alea = Int(D * Rnd) + 1
    If Tab_BD_Apres_Plat(Nb_Alea, 0) = 1 Then GoTo DepAlea4                                'Verifie que la ligne BD_Entr?es n'est pas deja choisi
    If Tab_BD_Apres_Plat(Nb_Alea, 3) = "D?sactiv?" Then GoTo DepAlea4                      'Colonne C ID_Plat " D?sactiv?

                    If Tab_BD_Apres_Plat(Nb_Alea, 1) = 4 Then                              'Colonne C ID_Plat " ENTRE, ACompagnement etc ...
                            Cells(Ligne_Tab, Col) = Tab_BD_Apres_Plat(Nb_Alea, 4)          'Entr?e dans la page Aff_Semaine

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Apres_Plat(Nb_Alea, 4)       'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Apres_Plat(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If

                            Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8      'sert a definir si les repas son inscris le midi et le soir
                            Tab_BD_Apres_Plat(Nb_Alea, 0) = 1                              ' Change la valeur de la colonne en 1 Pour ne pas rechoisir ? nouveau le plat

                        Sheets("BD_Repas").Cells(Nb_Alea + 2, 25) = 1                    'Inscription dans la grille des MENUS
                                Mem_Col = Mem_Col + 1

                       End If

                Wend
                        'Sheets("Aff_Semaine").Cells("B5").Select
Fin4:
'======================================================================================
'                   Remplissage de la grille semaine pour les D?sserts
'==================================a====================================================
If Sheets("Criteres").Cells(6, 13) <> "" Then GoTo Fin5
'=======================================================================================
    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

Mem_Ligne = 6   'Position de la Ligne dans la page Criteres
Mem_Col = 13    'Position de la colonne dans la page Criteres
Ligne_Tab = 6
'======================================================================================
          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

E = UBound(Tab_BD_Dessert, 1)
'=========D?but de la Boucle et verifie si assez de plat ==============================

                    While Len(Range("I" & Actif)) = Lg

                        If Sheets("BD_Repas").Cells(2, 33) = Rep_Ligne - 2 Then 'Comptabilise les enregistrements jusqu'? la cellule 500
                                MsgBox "- il n'y a plus de D?sserts disponibles." & Chr(10) & Chr(10) _
                                & "- Veuillez passer par le menu pour remettre ? Z?ro la Base (D?sserts)", vbInformation
                            GoTo Fin5
                        End If

'=============================Chiffre aleatoire =======================================
DepAlea5:
Nb_Alea = 0
    Randomize
'Nombre al?atoire entier entre 1 et 50 : pour commencer, ensuite ce regler sur la longueur de la table.
    Nb_Alea = Int(D * Rnd) + 1
    If Tab_BD_Dessert(Nb_Alea, 0) = 1 Then GoTo DepAlea5                                'Verifie que la ligne BD_Entr?es n'est pas deja choisi
    If Tab_BD_Dessert(Nb_Alea, 3) = "D?sactiv?" Then GoTo DepAlea5                      'Colonne C ID_Plat " D?sactiv?

                    If Tab_BD_Dessert(Nb_Alea, 1) = 5 Then                              'Colonne C ID_Plat " ENTRE, ACompagnement etc ...
                            Cells(Ligne_Tab, Col) = Tab_BD_Dessert(Nb_Alea, 4)          'Entr?e dans la page Aff_Semaine

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Dessert(Nb_Alea, 4)       'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Dessert(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If

                            Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8      'sert a definir si les repas son inscris le midi et le soir
                            Tab_BD_Dessert(Nb_Alea, 0) = 1                              ' Change la valeur de la colonne en 1 Pour ne pas rechoisir ? nouveau le plat

                        Sheets("BD_Repas").Cells(Nb_Alea + 2, 33) = 1                    'Inscription dans la grille des MENUS
                                Mem_Col = Mem_Col + 1

                       End If

                Wend
                        'Range("Aff_Semaine!B").Select
Fin5:
'=======================================================================================
'                   Fin des Seclection des Menus Remplissage de la Grille AFF_Semaine
'=====================================================================================
TEST:
Mem_Ligne = 2
Mem_Col = 13
Ligne_Tab = 6
Col = 3
Ligne = 6
'=====================================================================================
'                   Cr?ation du Tableau Tampon des Assemblage MENU
'======================================================================================
    Range("Aff_Semaine!C6:I6").ClearContents
    Range("Aff_Semaine!C8:I8").ClearContents

          If Actif = 6 Then Lg = Len(Range("I6"))   'Range("I6") pour Midi seulement
          If Actif = 8 Then Lg = Len(Range("I8"))   'Range("I8") pour Midi et Soir

        Derniere_Ligne = Sheets("Criteres").Range("M65000").End(xlUp).Row

                If Derniere_Ligne >= 1 Then 'SI BD PAS VIDE

                    ReDim Tab_MENU(Derniere_Ligne - 2, 9) ' descendre de 2 ligne, 6 = Nb de colonne

                          For I = 13 To 19
                             Tab_MENU(0, 0) = Sheets("Criteres").Cells(2, Mem_Col)      'Midi Entr?e
                             Tab_MENU(1, 1) = Sheets("Criteres").Cells(3, Mem_Col)      'Midi Plats
                             Tab_MENU(2, 2) = Sheets("Criteres").Cells(4, Mem_Col)      'Midi Accomp
                             Tab_MENU(3, 3) = Sheets("Criteres").Cells(5, Mem_Col)      'Midi Apres
                             Tab_MENU(4, 4) = Sheets("Criteres").Cells(6, Mem_Col)      'Midi Dessert
                             Tab_MENU(0, 5) = Sheets("Criteres").Cells(8, Mem_Col)      'Soir Entr?e
                             Tab_MENU(1, 6) = Sheets("Criteres").Cells(9, Mem_Col)      'Soir Plats
                             Tab_MENU(2, 7) = Sheets("Criteres").Cells(10, Mem_Col)     'Soir Accomp
                             Tab_MENU(3, 8) = Sheets("Criteres").Cells(11, Mem_Col)     'Soir Apres
                             Tab_MENU(4, 9) = Sheets("Criteres").Cells(12, Mem_Col)     'Soir Dessert

                 If Ligne_Tab = 6 Then
        Sheets("Criteres").Cells(Mem_Ligne, Mem_Col) = Tab_BD_Entrees(Nb_Alea, 4)           'Inscription dans la grille des MENUS
                 Else
        Sheets("Criteres").Cells(Mem_Ligne + 6, Mem_Col - 7) = Tab_BD_Entrees(Nb_Alea, 4)   'Inscription dans la grille des MENUS
                 End If

                            Cells(Ligne_Tab, Col) = "- " & Tab_MENU(0, 0) _
                                    & Chr(10) & "- " & Tab_MENU(1, 1) _
                                    & Chr(10) & "- " & Tab_MENU(2, 2) _
                                    & Chr(10) & "- " & Tab_MENU(3, 3) _
                                    & Chr(10) & "- " & Tab_MENU(4, 4)

                        Col = Col + 1: If Col = 10 Then Col = 3: Ligne_Tab = 8      'sert a definir si les repas son inscris le midi et le soir
Mem_Col = Mem_Col + 1
                        Next I
              End If
                        Range("Aff_Semaine!B4").Select
'=====================================================================================
            MsgBox "- Le menu de la semaine est complet", vbInformation

End Sub
36menus-semainev02.xlsm (495.64 Ko)
Le 25/02/2020 à 10:40

Bonjour Domy59,

Tout d'abord, les macros Case_Rouge et Case_Verte ont posées un souci.

J'ai modifié le code existant par:

ActiveSheet.Shapes("Case_Cocher_Rouge").Zorder msoSendBackward
ActiveSheet.Shapes("Rectangle à coins arrondis 5").TextFrame2.Text = "Avec les repas du soir"

Faire de même pour l'autre case avec changement du texte.

Suite pour les tableaux...

Le 25/02/2020 à 10:43

A nouveau,

Réduction du code pour la création de tableaux. Mise en place d'un tableau global et d'une boucle suplémentaire pour ôter des lignes de code.

Voir Image jointe pour le 1ier tableau.

capttabentrees

Suite pour 2iéme tableau...

Le 25/02/2020 à 10:47

A nouveau,

Pour le 2ième tableau:

capttabplats

Ensuite faire de même pour les autres tableaux selon notes.

Puis reposter le fichier une fois les modifications réalisées et le code réduit et le test OK.

Si interrogation me laisser un retour.

Bons tests, bonne continuation.

Le 25/02/2020 à 17:17

Merci X Cellus

je regarde les codes, je les met en place et te fait un retour.

Bonne journée

Le 26/02/2020 à 23:33

Bonsoir X Cellus,

Merci pour ta réponse concernant la reduction de mon code.

sauf erreur de ma par dans la retranscription, j'ai une erreur 13 sur le 1er tableau et il ne va pas plus loin ?

je te joint en copie ecran, l'erreur .

merci d'avance pour ton aide.

erreur 13
Le 26/02/2020 à 23:43

Bonsoir Domy59,

Bien ton nouveau éditeur. Par contre as tu Dimensionner la variable A? Par DIM A(6) par exemple?

Puis les formules dans chaque table en ligne 2 ressortent bien des nombres? Le format est-il number sans décimal?

A suivre...

Le 27/02/2020 à 00:08

Suite,

Ci-dessous, le code après une première réduction tel qu'annoncé dans mon précédent post.

Il peut se réduire encore, en seulement 6 lignes pour réaliser à l'identique le tableau global.

Vérifie avec celui que tu as élaboré.

'======================================================================================
'                   Création du Tableau GLOBAL Entrées, Plats, etc.... "Verifié le 25/02 OK"
'======================================================================================
                          'Tot = 0
                          For I = 1 To A(0) 'UBound(Tab_BD_Semaine, 1)
                          For J = 0 To 5
                          Col = J + 1 - (J = 5) 'Note: ici le chiffre 5 correspond à la colonne Plat Dispo
                          Tab_BD_Semaine(I, J) = Sheets("BD_Repas").Cells(I + 2, Col) 'Colonne B ID_Fait
                          Next J, I
'======================================================================================
'                   Création du Tableau Plats "Verifié le 25/02 OK"
'======================================================================================
                         Tot = A(0)
                         For I = 1 To A(1) 'UBound(Tab_BD_Semaine, 1)
                         For J = 0 To 5
                         Col = J + 9 - (J = 13) 'Note: ici le chiffre 13 correspond à la colonne Plat Dispo
                         Tab_BD_Semaine(I + Tot, J) = Sheets("BD_Repas").Cells(I + 2, Col) 'Colonne B ID_Fait
                         Next J, I
'======================================================================================
'                   Création du Tableau Accompagnement "Verifié le 25/02 OK"
'======================================================================================
                         Tot = Tot + A(1)
                         For I = 1 To A(2) 'UBound(Tab_BD_Accompagnement, 1)
                         For J = 0 To 5
                         Col = J + 17 - (J = 21) 'Note: ici le chiffre 21 correspond à la colonne Plat Dispo
                         Tab_BD_Semaine(I + Tot, J) = Sheets("BD_Repas").Cells(I + 2, Col) 'Colonne B ID_Fait
                         Next J, I
'======================================================================================
'                   Création du Tableau Aprés Plats "Verifié le 25/02 OK"
'======================================================================================
                         Tot = Tot + A(2)
                         For I = 1 To A(3) 'UBound(Tab_BD_Accompagnement, 1)
                         For J = 0 To 5
                         Col = J + 25 - (J = 29) 'Note: ici le chiffre 21 correspond à la colonne Plat Dispo
                         Tab_BD_Semaine(I + Tot, J) = Sheets("BD_Repas").Cells(I + 2, Col) 'Colonne B ID_Fait
                         Next J, I
'======================================================================================
'                   Création du Tableau Desserts "Verifié le 00/02 OK"
'======================================================================================
                         Tot = Tot + A(3)
                         For I = 1 To A(4) 'UBound(Tab_BD_Accompagnement, 1)
                         For J = 0 To 5
                         Col = J + 33 - (J = 37) 'Note: ici le chiffre 21 correspond à la colonne Plat Dispo
                         Tab_BD_Semaine(I + Tot, J) = Sheets("BD_Repas").Cells(I + 2, Col) 'Colonne B ID_Fait
                         Next J, I
            'Test tableaux
            For K = 1 To Tot + A(3) 'Pour l'ensemble sera Tot + A(4)
            Sheets("Criteres").Cells(K, 22) = Tab_BD_Semaine(K, 4)
            Next K
            Stop   'pour stopper la macro puis vérifier la colonne V de la feuille Criteres

Bons tests, bonne continuation.

Rechercher des sujets similaires à "alleger code"