跪求大佬帮忙解决下。研究了好久做不到

hzx091218

配货.rar (7.1 KB, 下载次数: 26)

2020-2-25 17:25 上传

点击文件名下载附件

cnmlgb9998

能不能把问题写清楚？ 要求写明白？

hzx091218

sheet2 是全国库存。 sheet1 是订单量。 需要按顺序从全国库存里面满足订单 需求。

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("sheet2")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a1:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 2)) Then
    
11.         m = 1
    
12.         ReDim brr(1 To 2, 1 To m)
    
13.       Else
    
14.         brr = d(arr(i, 2))
    
15.         m = UBound(brr, 2) + 1
    
16.         ReDim Preserve brr(1 To 2, 1 To m)
    
17.       End If
    
18.       brr(1, m) = arr(i, 1)
    
19.       brr(2, m) = arr(i, 3)
    
20.       d(arr(i, 2)) = brr
    
21.     Next
    
22.   End With
    
23.   With Worksheets("sheet1")
    
24.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
25.     .Range("c2:h" & r).ClearContents
    
26.     arr = .Range("a2:h" & r)
    
27.     For i = 1 To UBound(arr)
    
28.       n = 3
    
29.       sl = arr(i, 2)
    
30.       If d.exists(arr(i, 1)) Then
    
31.         brr = d(arr(i, 1))
    
32.         For j = 1 To UBound(brr, 2)
    
33.           If brr(2, j) > 0 Then
    
34.             If brr(2, j) > sl Then
    
35.               arr(i, n) = brr(1, j)
    
36.               arr(i, n + 1) = sl
    
37.               brr(2, j) = brr(2, j) - sl
    
38.               sl = 0
    
39.             Else
    
40.               arr(i, n) = brr(1, j)
    
41.               arr(i, n + 1) = brr(2, j)
    
42.               sl = sl - brr(2, j)
    
43.               brr(2, j) = 0
    
44.             End If
    
45.             n = n + 2
    
46.           End If
    
47.           If sl = 0 Then
    
48.             Exit For
    
49.           End If
    
50.         Next
    
51.         d(arr(i, 1)) = brr
    
52.       End If
    
53.     Next
    
54.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
55.   End With
    
56. End Sub
    

复制代码

chxw68

详见附件。

hzx091218

chxw68 发表于 2020-2-25 18:13
详见附件。

太感谢大佬了。

好好学习您的代码！

orr89

chxw68 发表于 2020-2-25 18:12

版主太强大了