多表提取不重复值

oxnnd

详细见附件，请各位大神帮忙！

zax010

1. Sub zz()
   
2.     Dim d, ar, br, cr, dr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     ar = Sheet12.Range("A3").CurrentRegion
   
5.     br = Sheet2.Range("A3").CurrentRegion
   
6.     cr = Sheet6.Range("A3").CurrentRegion
   
7.     dr = Sheet1.Range("A1").CurrentRegion
   
8.     For i = 2 To UBound(dr)
   
9.         For j = 4 To UBound(dr, 2) - 2
   
10.             d(dr(i, 2) & dr(i, 3) & dr(1, j)) = 0
    
11.         Next
    
12.     Next
    
13.     For i = 4 To UBound(ar)
    
14.         For j = 5 To 11
    
15.             If d.exists(ar(i, 3) & ar(i, 4) & ar(3, j)) Then
    
16.                 d(ar(i, 3) & ar(i, 4) & ar(3, j)) = d(ar(i, 3) & ar(i, 4) & ar(3, j)) + ar(i, j)
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     For i = 4 To UBound(br)
    
21.         For j = 5 To 11
    
22.             If d.exists(br(i, 3) & br(i, 4) & br(3, j)) Then
    
23.                 d(br(i, 3) & br(i, 4) & br(3, j)) = d(br(i, 3) & br(i, 4) & br(3, j)) + br(i, j)
    
24.             End If
    
25.         Next
    
26.     Next
    
27.     For i = 4 To UBound(cr)
    
28.         For j = 5 To 11
    
29.             If d.exists(cr(i, 3) & cr(i, 4) & cr(3, j)) Then
    
30.                 d(cr(i, 3) & cr(i, 4) & cr(3, j)) = d(cr(i, 3) & cr(i, 4) & cr(3, j)) - cr(i, j)
    
31.             End If
    
32.         Next
    
33.     Next
    
34.     For i = 2 To UBound(dr)
    
35.         For j = 4 To UBound(dr, 2) - 2
    
36.             dr(i, j) = d(dr(i, 2) & dr(i, 3) & dr(1, j))
    
37.             dr(i, 11) = dr(i, 11) + dr(i, j)
    
38.         Next
    
39.     Next
    
40.     Sheet1.Range("A1").CurrentRegion = dr
    
41. End Sub
    

复制代码

zax010

>>>>>>>>>>>>>>>>>>>>>>



进销存.rar (182.74 KB, 下载次数: 86)

2016-6-20 20:22 上传

点击文件名下载附件

oxnnd

zax010 发表于 2016-6-20 20:22
>>>>>>>>>>>>>>>>>>>>>>

大神你好，1052以及那三个颜色是我做的例子，实际是要把入库、退货、发货中每个款号、以及对应的颜色提取出来,不要重复的

zax010

1. Sub zz()
   
2.     Dim d, d1, ar, br, cr, dr, m%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     ar = Sheet12.Range("A3").CurrentRegion
   
6.     br = Sheet2.Range("A3").CurrentRegion
   
7.     cr = Sheet6.Range("A3").CurrentRegion
   
8.     Sheet1.Range("A2:L500").ClearContents
   
9.     dr = Sheet1.Range("A1:L500"): m = 1
   
10.     For i = 4 To UBound(ar)
    
11.         For j = 5 To 11
    
12.             d1(ar(i, 3) & "," & ar(i, 4)) = ""
    
13.             d(ar(i, 3) & ar(i, 4) & ar(3, j)) = d(ar(i, 3) & ar(i, 4) & ar(3, j)) + ar(i, j)
    
14.         Next
    
15.     Next
    
16.     For i = 4 To UBound(br)
    
17.         For j = 5 To 11
    
18.             d1(br(i, 3) & "," & br(i, 4)) = ""
    
19.             d(br(i, 3) & br(i, 4) & br(3, j)) = d(br(i, 3) & br(i, 4) & br(3, j)) + br(i, j)
    
20.         Next
    
21.     Next
    
22.     For i = 4 To UBound(cr)
    
23.         For j = 5 To 11
    
24.             d1(cr(i, 3) & "," & cr(i, 4)) = ""
    
25.             d(cr(i, 3) & cr(i, 4) & cr(3, j)) = d(cr(i, 3) & cr(i, 4) & cr(3, j)) - cr(i, j)
    
26.         Next
    
27.     Next
    
28.     For Each k In d1.keys
    
29.         a = Split(k, ","): m = m + 1
    
30.         dr(m, 1) = m - 1: dr(m, 2) = a(0): dr(m, 3) = a(1)
    
31.         For j = 4 To UBound(dr, 2) - 2
    
32.             dr(m, j) = d(dr(m, 2) & dr(m, 3) & dr(1, j))
    
33.             dr(m, 11) = dr(m, 11) + dr(m, j)
    
34.         Next
    
35.     Next
    
36.     Sheet1.Range("A1").Resize(m, UBound(dr, 2)) = dr
    
37. End Sub
    

复制代码

jjmysjg

留下，好答案

blackttea1

学习啦，谢谢