还是比较有代表性意义的，有挑战的，订单数据处理的问题！

zhua

业务数据-产品明细 表

订单号	条形码	产品名称	数量	单价	金额
1	F0032	产品套装A	1	90	90
2	C0042	产品套装B	2	280	560
3	U045	产品套装A+B	3	180	540
4	F003	产品A	1	49	49
4	C004	产品B	2	142	284

产品组合 表

套装产品编号	套装规格	套装等级一价格	相关产品编号	相关产品数量	相关产品品名	相关产品等级一价格
C0042	产品套装B	284	C004	2	产品B	142
F0032	产品套装A	98	F003	2	产品A	49
U045	产品套装A+B	191	C004	1	产品B	142
U045	产品套装A+B	191	F003	1	产品A	49

要得到这样的表：

订单号	条形码	产品名称	数量	单价	金额	备注
1	F003	产品A	2	45	90	套装
2	C004	产品B	4	140	560	套装
3	F003	产品A	3	46.18	138.5	套装
3	C004	产品B	3	133.82	401.5	套装
4	F003	产品A	1	49	49
4	C004	产品B	2	142	284

结果需求表解析：

例子 副本.zip (7.7 KB, 下载次数: 6)

2013-2-22 15:54 上传

点击文件名下载附件

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr, Crr(1 To 5000, 1 To 7)
   
3. Dim d, k, t, t1, aa, j&, b, n&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet3.Activate
   
6. Arr = Sheet1.[a1].CurrentRegion
   
7. Brr = Sheet2.[a1].CurrentRegion
   
8. For i = 2 To UBound(Brr)
   
9.     If Not d.exists(Brr(i, 2)) Then
   
10.         d.Add Brr(i, 2), i
    
11.     Else
    
12.         d(Brr(i, 2)) = d(Brr(i, 2)) & "," & i
    
13.     End If
    
14. Next
    
15. k = d.keys
    
16. t = d.items
    
17. For i = 2 To UBound(Arr)
    
18.     If d.exists(Arr(i, 3)) Then
    
19.         t1 = d(Arr(i, 3))
    
20.         If InStr(t1, ",") Then
    
21.             aa = Split(t1, ",")
    
22.             For j = 0 To UBound(aa)
    
23.                 n = n + 1
    
24.                 b = Arr(i, 5) / Brr(aa(j), 3)
    
25.                 Crr(n, 1) = Arr(i, 1)
    
26.                 Crr(n, 2) = Brr(aa(j), 4)
    
27.                 Crr(n, 3) = Brr(aa(j), 6)
    
28.                 Crr(n, 4) = Arr(i, 4) * Brr(aa(j), 5)
    
29.                 Crr(n, 6) = Format(Crr(n, 4) * Brr(aa(j), 7) * b, "0.0")
    
30.                 Crr(n, 5) = Format(Crr(n, 6) / Crr(n, 4), "0.00")
    
31.                 Crr(n, 7) = "套装"
    
32.             Next
    
33.         Else
    
34.             n = n + 1
    
35.             Crr(n, 1) = Arr(i, 1)
    
36.             Crr(n, 2) = Brr(t1, 4)
    
37.             Crr(n, 3) = Brr(t1, 6)
    
38.             Crr(n, 4) = Arr(i, 4) * Brr(t1, 5)
    
39.             Crr(n, 6) = Arr(i, 6)
    
40.             Crr(n, 5) = Crr(n, 6) / Crr(n, 4)
    
41.             Crr(n, 7) = "套装"
    
42.         End If
    
43.     Else
    
44.             n = n + 1
    
45.             Crr(n, 1) = Arr(i, 1)
    
46.             Crr(n, 2) = Arr(i, 2)
    
47.             Crr(n, 3) = Arr(i, 3)
    
48.             Crr(n, 4) = Arr(i, 4)
    
49.             Crr(n, 6) = Arr(i, 6)
    
50.             Crr(n, 5) = Arr(i, 5)
    
51.     End If
    
52. Next
    
53. [b3].Resize(n, 7) = Crr
    
54. End Sub
    

复制代码

蓝桥玄霜

请见附件。

zhua

谢谢。细细琢磨下代码。

zhua

由于我是举例，产品名称和套装的名称没有什么关系。
当我换了产品名称来测试就发生错误。

zhua

For i = 2 To UBound(Brr)
09.    If Not d.exists(Brr(i, 2)) Then
10.        d.Add Brr(i, 2), i
11.    Else
12.        d(Brr(i, 2)) = d(Brr(i, 2)) & "," & i
13.    End If
14.Next
15.k = d.keys
16.t = d.items
17.For i = 2 To UBound(Arr)
18.    If d.exists(Arr(i, 3)) Then
19.        t1 = d(Arr(i, 3))

应该是修改这么吧？