求一个递归算法并分享一个MRP源代码！见本贴9楼

jygzcj

这个论坛现在太冷清了。到时候我的附档下载数仍为0呀。什么情况呀。

没有病毒的呀。

袁振涛

5那个地方的判断跟你的不一致

1. Public objDic As Object
   
2. Public Arr
   
3. Sub Test_LLc()
   
4.     Set objDic = CreateObject("scripting.dictionary")
   
5.     Arr = [a1].CurrentRegion
   
6.     Dim Arr2(1 To 100)
   
7.     For i = 2 To UBound(Arr)
   
8.         getXnjData (i)
   
9.         Arr2(i - 1) = getData(Xnj(Arr(i, 1)))
   
10.     Next
    
11.     [c2].Resize(UBound(Arr2), 1) = Application.Transpose(Arr2)
    
12. End Sub
    
13. 
    
14. Function Xnj(intIndex)    'intindex变量存放层次的值
    
15.     If intIndex = 1 Then    '如果为最高的层次1，则可确定只存在两种状态，要么为Y,要么为X
    
16.         If objDic(1) <> "X" Then
    
17.             Xnj = "Y"
    
18.         Else
    
19.             Xnj = "X"
    
20.         End If
    
21.         Exit Function
    
22.     End If
    
23.     If intIndex > 1 Then    '如果intindex>1则判断其本身以及其上一个层次，两个即可得出
    
24.         If objDic(intIndex) = "X" Then
    
25.             Xnj = "X"
    
26.         Else
    
27.             If objDic(intIndex - 1) = "X" Then
    
28.                 Xnj = "Y"
    
29.             Else
    
30.                 Xnj = ""
    
31.             End If
    
32.         End If
    
33.     End If
    
34. End Function
    
35. Sub getXnjData(i%)    '如果当前层次为5，则从其上寻找距离最近的第一个层次为4、3、2、1的来源码
    
36.     objDic.RemoveAll    '清空字典
    
37.     Dim intLevel%
    
38.     intLevel = Arr(i, 1)    '取出当前的层次
    
39.     For j = i To 1 Step -1    '循环取出比当前层次更小的层次
    
40.         If Arr(j, 1) <= intLevel And Not objDic.exists(Arr(j, 1)) Then
    
41.             objDic(Arr(j, 1)) = Arr(j, 2)
    
42.         End If
    
43.     Next
    
44. End Sub
    
45. Function getData(strData$)
    
46. If strData = "Y" Then getData = "Y"
    
47. End Function

复制代码

袁振涛

第二次修改稿

1. Public Arr
   
2. Sub Test_LLc()
   
3. Dim i%
   
4.     Set objDic = CreateObject("scripting.dictionary")
   
5.     Arr = [a1].CurrentRegion
   
6.     ReDim Arr2(1 To UBound(Arr))
   
7.     For i = 2 To UBound(Arr)
   
8.         Arr2(i - 1) = getData(Xnj(i, Arr(i, 1)))
   
9.     Next
   
10.     [c2].Resize(UBound(Arr2), 1) = Application.Transpose(Arr2)
    
11. End Sub
    
12. 
    
13. Function Xnj(ByVal intIndex%, ByVal intLevel%)  'intIndex数组中的索引值,初始值，intlevel当前的层次
    
14.     Dim intCurrentLevel% '当前层次在数组中的索引值，与原始值相区别
    
15.     For j = intIndex To 1 Step -1    '取出当前层次
    
16.         If Arr(j, 1) = intLevel Then
    
17.             intCurrentIndex = j
    
18.             Exit For
    
19.         End If
    
20.     Next
    
21.     If intLevel = 1 Then    '本身即为第一级
    
22.         If Arr(intCurrentIndex, 2) <> "X" Then
    
23.             Xnj = "Y"
    
24.         Else
    
25.             Xnj = "X"
    
26.         End If
    
27.         Exit Function
    
28.     Else    '至少两级
    
29.         If Arr(intCurrentIndex, 2) = "X" Then
    
30.             Xnj = "X"
    
31.         Else
    
32.             If Xnj(intIndex, intLevel - 1) = "X" Then
    
33.                 Xnj = "Y"
    
34.             Else
    
35.                 Xnj = ""
    
36.             End If
    
37.         End If
    
38.     End If
    
39. End Function
    
40. 
    
41. Function getData(strData$)
    
42.     If strData = "Y" Then getData = "Y"
    
43. End Function
    

复制代码

jygzcj

1. Sub Test_LLc2()
   
2. 
   
3. 
   
4. Dim i%, j%, k% '定义几个for循环用的变量
   
5. Dim Lr% '定义本表格的行边界
   
6. 
   
7. Dim Sh As Worksheet '定义工作
   
8. Set Sh = Sheet4 '指定工作表
   
9. 
   
10. 
    
11. Lr = Sh.Range("A65536").End(xlUp).Row '指定行边界行数
    
12. 
    
13. Dim Arr '定义一个variant变量
    
14. 
    
15. Dim LLC% '定义一个BOM层次码变量
    
16. 
    
17. LLC = 1 '初始化为1
    
18. 
    
19. 
    
20. 'Arr = sh.Range("A2:C" & Lr) '将指定区域赋给Arr
    
21. 
    
22. i = 1
    
23. '开始循环判断
    
24. With Sh
    
25. Do
    
26.     i = i + 1
    
27.     If .Cells(i, 4) = 1 Then
    
28.         If .Cells(i, 11) <> "X" Then
    
29.            .Cells(i, 12) = "Y"
    
30.             Else
    
31.             i = Dg(i, LLC + 1)
    
32.             
    
33.         End If
    
34.     End If
    
35. Loop Until i = Lr
    
36. 
    
37. 
    
38. 
    
39. '.Cells(2, 1).Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
    
40. 
    
41. End With
    
42. Set Sh = Nothing '结束
    
43. 
    
44. 
    
45.   
    
46. End Sub
    
47. 
    
48. Function Dg(ByVal i_Row As Integer, ByVal S_Llc As Integer)
    
49. 
    
50. Dim Sh As Worksheet
    
51. Set Sh = Sheet4
    
52. 
    
53. 
    
54. With Sh
    
55.     Do
    
56.         i_Row = i_Row + 1
    
57.             If .Cells(i_Row, 4) = S_Llc Then
    
58.                     If .Cells(i_Row, 11) <> "X" Then
    
59.                             .Cells(i_Row, 12) = "Y"
    
60.                             'Dg = i_Row
    
61.                         Else
    
62.                             i_Row = Dg(i_Row, S_Llc + 1)
    
63.                     End If
    
64.                  Else
    
65.                     '
    
66.                
    
67.             End If
    
68.      
    
69.         
    
70.     Loop Until .Cells(i_Row, 4) = S_Llc - 1
    
71.    
    
72. End With
    
73.     Dg = i_Row - 1
    
74. 
    
75. End Function
    
76. 
    

复制代码

jygzcj

以上乱写的。效果是达到了，但是好像感觉不好。没有老师写得好。

jygzcj

袁振涛 发表于 2015-12-8 15:11
第二次修改稿

还有一个小小的问题，就是他上面的有参加的人，这个组织下面的 不管是虚拟的还是实际的，都不会计入了。效果我的代码我运算了一下可以的。但是没有你的思路好。看能否再帮忙看看。谢谢！

aman1516

jygzcj 发表于 2015-12-8 19:19
还有一个小小的问题，就是他上面的有参加的人，这个组织下面的 不管是虚拟的还是实际的，都不会计入了。 ...

能否做个目录么，对应每个的主功能，以便对应学习下。谢谢分享

袁振涛

你后面的递归代码比我的简洁多了
我又写了个字典的，非递归

1. Dim Arr, Arr2
   
2.     Dim intLevel%, strState$
   
3.     Dim objDic As Object
   
4.     Set objDic = CreateObject("scripting.dictionary")
   
5.     Arr = [a1].CurrentRegion
   
6.     ReDim Arr2(1 To UBound(Arr))
   
7.     For i = 2 To UBound(Arr)
   
8.         intLevel = Arr(i, 1)
   
9.         strState = Arr(i, 2)
   
10.         If (intLevel = 1) Then    '层级为1时
    
11.             objDic.RemoveAll    '清空字典并重建
    
12.             If strState = "X" Then    '虚拟件
    
13.                 Arr2(i) = "X"
    
14.                 objDic(1) = "X"
    
15.             Else
    
16.                 Arr2(i) = "Y"
    
17.                 objDic(1) = "Y"
    
18.             End If
    
19.         Else    '层级大于1时
    
20.             If strState = "X" Then   '虚拟件
    
21.                 Arr2(i) = "X"
    
22.                 objDic(intLevel) = "X"
    
23.             Else
    
24.                 If objDic(intLevel - 1) = "X" Then    '如果本层级非虚拟，则判断上级是否为虚拟
    
25.                     Arr2(i) = "Y"
    
26.                     objDic(intLevel) = "Y"
    
27.                 Else
    
28.                     Arr2(i) = ""
    
29.                     objDic(intLevel) = ""
    
30.                 End If
    
31.             End If
    
32.         End If
    
33.     Next
    
34.     For i = 2 To UBound(Arr)
    
35.     If Arr2(i) = "X" Then Arr2(i) = ""
    
36.     Next
    
37.     [c1].Resize(UBound(Arr), 1) = Application.Transpose(Arr2)

复制代码

jygzcj

袁振涛 发表于 2015-12-8 20:33
你后面的递归代码比我的简洁多了
我又写了个字典的，非递归

虚拟料阶发料展BOM.rar (34.21 KB, 下载次数: 173)

2015-12-8 21:39 上传

点击文件名下载附件

图示两行的不是我想要的，因为他的上阶3已经参加了，4是不是虚拟件无关紧要了。
不要重复发料。请帮再看一下。谢谢！
你的代码比较正规，我的是功能实现问题可能不少。

袁振涛

改了下

1. Dim Arr, Arr2
   
2.     Dim intLevel%, strState$
   
3.     Dim objDic As Object
   
4.     Set objDic = CreateObject("scripting.dictionary")
   
5.     Arr = [a1].CurrentRegion
   
6.     ReDim Arr2(1 To UBound(Arr))
   
7.     Dim boolCheck As Boolean
   
8.     boolCheck = False
   
9.     For i = 2 To UBound(Arr)
   
10.         intLevel = Arr(i, 1)
    
11.         strState = Arr(i, 2)
    
12.         If (intLevel = 1) Then    '层级为1时
    
13.             objDic.RemoveAll    '清空字典并重建
    
14.             If strState = "X" Then    '虚拟件
    
15.                 Arr2(i) = "X"
    
16.                 objDic(1) = "X"
    
17.             Else
    
18.                 Arr2(i) = "Y"
    
19.                 objDic(1) = "Y"
    
20.             End If
    
21.         Else    '层级大于1时
    
22.             If strState = "X" Then   '虚拟件
    
23.                 Arr2(i) = "X"
    
24.                 objDic(intLevel) = "X"
    
25.             Else
    
26.                 For j = 1 To intLevel - 1
    
27.                     If objDic(j) <> "X" Then
    
28.                         boolCheck = True
    
29.                     End If
    
30.                 Next
    
31.                 If boolCheck = False Then   '如果本层级非虚拟，则判断上级是否为虚拟
    
32.                     Arr2(i) = "Y"
    
33.                     objDic(intLevel) = "Y"
    
34.                 Else
    
35.                     Arr2(i) = ""
    
36.                     objDic(intLevel) = ""
    
37.                 End If
    
38.                 boolCheck = False
    
39.             End If
    
40.         End If
    
41.     Next
    
42.     For i = 2 To UBound(Arr)
    
43.         If Arr2(i) = "X" Then Arr2(i) = ""
    
44.     Next
    
45.     [c1].Resize(UBound(Arr), 1) = Application.Transpose(Arr2)

复制代码