求助，汇总求和，感谢！

szgzqg

请见附件，里边写好想要达成的结果，谢谢！

kzg2013

Sub summ()


Dim D As Object, sh1 As Object, sh2 As Object
Set sh1 = Sheets("交货排程")
Set sh2 = Sheets("备料汇总")

R = sh1.UsedRange.Rows.Count
Rng = sh1.Range("D4:I" & R)
Set D = CreateObject("SCRIPTING.DICTIONARY")
  For K = 1 To UBound(Rng)
     If Rng(K, 1) = "备料" Then
          D(Rng(K, 2)) = D(Rng(K, 2)) + Rng(K, 6)
     End If
Next K


sh2.[A2].Resize(D.Count, 1) = "备料"
sh2.[B2].Resize(D.Count, 1) = Application.Transpose(D.KEYS)
sh2.[C2].Resize(D.Count, 1) = Application.Transpose(D.ITEMS)


Set D = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

mjzxlmg

1. Sub mjzxlmg()
   
2.     Dim arr, i&, m&, dic As New Dictionary
   
3.     arr = Sheets("???????").[a1].CurrentRegion.Value
   
4.     ReDim result(1 To UBound(arr), 1 To 3)
   
5.     result(1, 1) = "????????": result(1, 2) = "???": result(1, 3) = "δ??????"
   
6.     m = 1
   
7.     For i = 4 To UBound(arr)
   
8.         If arr(i, 4) = "????" Then
   
9.             If dic.Exists(arr(i, 5)) = False Then
   
10.                 m = m + 1
    
11.                 dic(arr(i, 5)) = m
    
12.                 result(m, 1) = arr(i, 4)
    
13.                 result(m, 2) = arr(i, 5)
    
14.                 result(m, 3) = arr(i, 9)
    
15.             Else
    
16.                 result(dic(arr(i, 5)), 3) = result(dic(arr(i, 5)), 3) + arr(i, 9)
    
17.             End If
    
18.         End If
    
19.     Next
    
20.     Application.ScreenUpdating = False
    
21.     With Sheets("???????")
    
22.         .UsedRange.ClearContents
    
23.         .[a1].Resize(m, 3).Value = result
    
24.         .Activate
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

mjzxlmg

测试附件：
2019业务排程1.rar (385.97 KB, 下载次数: 35)

2019-4-21 20:43 上传

点击文件名下载附件

szgzqg

mjzxlmg 发表于 2019-4-21 20:44
测试附件：

非常谢谢！！

szgzqg

kzg2013 发表于 2019-4-21 20:36
Sub summ()

非常谢谢！