求助大神 --如何根据日期和数量自动排期

jackycao2017

求助大神 --如何根据日期和数量自动排期

jackycao2017

请哪位大神帮帮忙。谢谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("物料排期")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.     rq1 = CDate(Application.Min(.Range("c2:c" & r)))
   
10.     ReDim bt(1 To 121)
    
11.     bt(1) = "物料"
    
12.     bt(2) = rq1
    
13.     For j = 3 To UBound(bt)
    
14.       bt(j) = bt(j - 1) + 1
    
15.     Next
    
16.     For i = 1 To UBound(arr)
    
17.       sl = arr(i, 4)
    
18.       If Not d.exists(arr(i, 1)) Then
    
19.         ReDim brr(1 To UBound(bt))
    
20.         brr(1) = arr(i, 1)
    
21.       Else
    
22.         brr = d(arr(i, 1))
    
23.       End If
    
24.       For j = 2 To UBound(bt)
    
25.         If bt(j) = arr(i, 3) Then
    
26.           Exit For
    
27.         End If
    
28.       Next
    
29.       If j <= UBound(bt) Then
    
30.         For k = j To UBound(brr)
    
31.           If arr(i, 2) < sl Then
    
32.             brr(k) = arr(i, 2)
    
33.             sl = sl - brr(k)
    
34.           Else
    
35.             brr(k) = sl
    
36.             sl = 0
    
37.             Exit For
    
38.           End If
    
39.         Next
    
40.       End If
    
41.       d(arr(i, 1)) = brr
    
42.     Next
    
43.   End With
    
44.   jsrq = 0
    
45.   With Worksheets("结果")
    
46.     .Cells.Clear
    
47.     .Range("a1").Resize(1, UBound(bt)) = bt
    
48.     m = 1
    
49.     For Each aa In d.keys
    
50.       m = m + 1
    
51.       brr = d(aa)
    
52.       For j = UBound(brr) To 1 Step -1
    
53.         If Len(brr(j)) <> 0 Then
    
54.           Exit For
    
55.         End If
    
56.       Next
    
57.       If jsrq < j Then
    
58.         jsrq = j
    
59.       End If
    
60.       .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
61.     Next
    
62.     .Columns(jsrq + 1).Resize(, .Columns.Count - jsrq).Clear
    
63.   End With
    
64. End Sub
    

复制代码

chxw68

刚写过类似的代码。

jackycao2017

非常感谢chxw68 大神的帮忙，问题已基本得到解决。请抽空再帮忙完善：A列中的物料第二次出现时，如果需求实际冲突（前面第一次还未排完），当天数据累加，已保证缺料总数和排出来的总数相等。谢谢！

chxw68

修改好了。