同表格相同编码汇总求和

auxzhb

表格中出现重复的编码码以及相应信息
1、编码重复只取唯一
2、物料名称、配件数量，重量与编码的信息对应
3、生产需求和物料需求要汇总求和
4、谢谢老师和大神帮忙

hlly888

1. Sub yy() 'hlly888
   
2. Range("L2:q65536").ClearContents
   
3. Application.ScreenUpdating = False
   
4. Dim dc As Object, arr, brr(), i&, x&, s&, w, j%
   
5. Set dc = CreateObject("scripting.dictionary")
   
6. x = Cells(Rows.Count, 4).End(xlUp).Row
   
7. arr = Range("d2:i" & x)
   
8. ReDim brr(1 To UBound(arr), 1 To 6)
   
9.    
   
10.     For i = 1 To UBound(arr)
    
11.         w = dc(arr(i, 1))
    
12.         If w = "" Then
    
13.            s = s + 1
    
14.            For j = 1 To 6
    
15.                brr(s, j) = brr(s, j) + arr(i, j)
    
16.            Next
    
17.            dc(arr(i, 1)) = s
    
18.            w = s
    
19.         Else
    
20.            For j = 3 To 6
    
21.                brr(w, j) = brr(w, j) + arr(i, j)
    
22.            Next
    
23.         End If
    
24.     Next
    
25.   
    
26. [L2].Resize(UBound(arr), 6) = brr
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

hlly888

汇总求和.zip (23.72 KB, 下载次数: 61)

2015-9-17 15:50 上传

点击文件名下载附件

wzb5566

1. Sub test()
   
2. Set dic = CreateObject("scripting.dictionary")
   
3. ReDim brr(1 To 6, 1 To 1)
   
4. arr = Range("D2:I" & [A65536].End(xlUp).Row)
   
5. For i = 1 To UBound(arr, 1)
   
6.     If Not dic.exists(arr(i, 1)) Then
   
7.         k = k + 1
   
8.         dic(arr(i, 1)) = k
   
9.         ReDim Preserve brr(1 To 6, 1 To k)
   
10.         For j = 1 To 6
    
11.             brr(j, k) = arr(i, j)
    
12.         Next
    
13.     Else
    
14.         For j = 3 To 6
    
15.             brr(j, dic(arr(i, 1))) = brr(j, dic(arr(i, 1))) + arr(i, j)
    
16.         Next
    
17.     End If
    
18. Next
    
19. Range("L2:Q" & [L65536].End(xlUp).Row + 1).ClearContents
    
20. [L2].Resize(UBound(brr, 2), UBound(brr, 1)) = Application.Transpose(brr)
    
21. End Sub
    

复制代码

wzb5566

供参考。。

Chip_Kenny

Sub zz()
Dim arr, d
Set d = CreateObject("scripting.dictionary")
arr = Range("d2:i" & Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
        d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
    Else
        d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), _
        d(arr(i, 1))(4) + arr(i, 5), d(arr(i, 1))(5) + arr(i, 6))
    End If
Next
t = Application.Transpose(Application.Transpose(d.items))
[l2].Resize(d.Count, UBound(t, 2)) = t
End Sub

jinnniuexcel

Chip_Kenny 发表于 2015-9-17 15:59
Sub zz()
Dim arr, d
Set d = CreateObject("scripting.dictionary")

请问这句怎么理解？   

Else
         d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), _
         d(arr(i, 1))(4) + arr(i, 5), d(arr(i, 1))(5) + arr(i, 6))

如果改成 d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4),  d(arr(i, 1)) + arr(i, 5), d(arr(i, 1)) + arr(i, 6))  可以吗 ？  

十分感谢

Chip_Kenny

1. 可理解成 字典(x) 裝下數組(0a,1b,2c,3d,4e,5f)
2. 字典(x)(4) = 4e
由此可知您的改法是不行的。

jinnniuexcel

Chip_Kenny 发表于 2018-6-15 11:20
1. 可理解成 字典(x) 裝下數組(0a,1b,2c,3d,4e,5f)
2. 字典(x)(4) = 4e
由此可知您的改法是不行的。

十分感谢大神的指点

LMY123

字典分类汇总

1. Sub zzC()
   
2. Dim arr, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("d2:i" & Cells(Rows.Count, 1).End(3).Row)
   
5. For i = 1 To UBound(arr)
   
6.     If Not d.exists(arr(i, 1)) Then
   
7.         d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
   
8.     Else
   
9.         d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), _
   
10.         d(arr(i, 1))(2) + arr(i, 3), d(arr(i, 1))(3) + arr(i, 4), d(arr(i, 1))(4) + arr(i, 5), d(arr(i, 1))(5) + arr(i, 6))
    
11.     End If
    
12. Next
    
13. t = Application.Transpose(Application.Transpose(d.items))
    
14. [l2].Resize(d.Count, UBound(t, 2)) = t
    
15. End Sub

复制代码