Distribution de quantité

Bonjour,

Voici une proposition, je n'ai pas le temps de trop approfondir mais vous avez les grandes lignes, à vous de peaufiner s'il manque quelque chose.

Allez sur la feuille "Stocks_disponibles" et cliquez sur le bouton "Répartitions et Stocks", le résultat est directement appliqué au tableau de gauche.
Si vous souhaitez rejouer le scénario avec le même tableau d'origine, cliquez sur la "Flèche Courbe" pour recopier le tableau original à la place du tableau de gauche.

Le fichier
Pièce jointe 580245

Le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
Dim DerLig_f1 As Long, DerCol_f1 As Long
Dim DerLig_f2 As Long, DerCol_f2 As Long
Dim DerLig_f3 As Long, DerCol_f3 As Long
Dim i As Long, j As Long
Dim d1 As Object, r As Object, s As Object, p As Object
Dim PosTiretBas As Long
Dim Ref As String, Stock As String, Valeur As String, Site As String, Art As String, Plage As String
Dim Cpt As Long, k As Long, Qte As Long
 
Sub Repartition_et_Stock()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Commandes")
    Set f2 = Sheets("Stocks_disponibles")
    Set f3 = Sheets("Affectation_Priorites_Stock")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f1 = f1.Range("A1").End(xlToRight).Column
 
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f2 = f2.Range("B1").End(xlToRight).Column
    DerLig_f3 = f3.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f3 = f3.Range("A1").End(xlToRight).Column
 
    For j = 2 To DerCol_f1 'on recherche les priorités
        For i = 4 To DerLig_f1
            If f1.Cells(i, j) <> "" Then
                Art = f1.Cells(i, "A") 'Récupération du N° de l'article
                Site = f1.Cells(2, j) 'récupération du Site
                Ref = Art & "_" & Site 'récupèration de la priorité "Art et Site"
                Qte = f1.Cells(i, j) 'Quantité demandée
                'on recherche les priorités dédiées à ce site dans la feuille "Affectation_Priorites_Stock"
                Set s = f3.Range("A2:A" & DerLig_f3).Find(Site, lookat:=xlPart) 'recherche du site dans la feuille "Affectation_Priorites_Stock"
                Cpt = 0
                ReDim Prio(Cpt) As String
                If Not s Is Nothing Then
                    For k = 2 To DerCol_f3
                        If f3.Cells(s.Row, k) <> "" Then
                            Prio(Cpt) = f3.Cells(s.Row, k)
                            Cpt = Cpt + 1
                            ReDim Preserve Prio(Cpt)
                        End If
                    Next k
                End If
 
                'on recherche par priorités
                For k = 0 To Cpt
                    Set p = f2.Range(f2.Cells(1, "B"), f2.Cells(1, DerCol_f2)).Find(Prio(k))
                    If Not p Is Nothing Then
                        'dans la feuille "Stocks_disponibles", on retire la quantité demandée en fonction des priorités
                        Set r = f2.Range("A2:A" & DerLig_f2).Find(Ref, lookat:=xlWhole) 'recherche de la référence dans la feuille "Stocks disponibles"
                        If Not r Is Nothing Then
                                If f2.Cells(r.Row, p.Column).MergeCells Then 'si la cellule est un ensemble de cellules fusionnées
                                    Plage = f2.Cells(r.Row, p.Column).Cells(1, 1).Address
                                Else 'Si la cellule ne fait pas partie d'un ensemble de cellules fusionnées
                                    Plage = f2.Cells(r.Row, p.Column).Address
                                End If
                                If f2.Cells(r.Row, p.Column) >= Qte Then 'Si le stock est supérieur à la quantité demandée
                                    f2.Cells(r.Row, p.Column) = f2.Range(Plage).Value - Qte
                                    Exit For
                                ElseIf f2.Range(Plage).Value < Qte Then 'Si le stock est inférieur à la quantité demandée
                                    f2.Range(Plage).Value = 0 'on amet le stock à zéro
                                    'on passe à la priorité suivante
                                End If
                        End If
                    End If
                Next k
            End If
        Next i
    Next j
 
    Set p = Nothing
    Set r = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Cdlt