带条件不重复粘贴汇总

sdgyc

带条件不重复粘贴汇总.rar (7.09 KB, 下载次数: 10)

2015-11-1 11:47 上传

点击文件名下载附件
附件

请求老师帮忙：带条件不重复粘贴汇总
当Q列等于P列或少于P列不重复粘贴编号C列、商品名称E列、规格型号G列、计量单位G列、参考单价L列、送货单位K列到申购计划表的编号C列、商品名称D列、规格型号E列、计量单位F列、参考单价G列、送货单位J列的对应列。汇总计划量M列对应到申购计划表的计划量H列的对应列。
多谢！！！

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&
   
3. Dim d, k, t, d1
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Sheet15.Activate
   
7. [c5:j500].ClearContents
   
8. Arr = Sheet9.[c3].CurrentRegion
   
9. For i = 2 To UBound(Arr)
   
10.     If Arr(i, 15) <= Arr(i, 14) Then
    
11.         d(Arr(i, 1)) = d(Arr(i, 1)) + Arr(i, 11)
    
12.         If Not d1.exists(Arr(i, 1)) Then d1(Arr(i, 1)) = i
    
13.     End If
    
14. Next
    
15. k = d.keys: t = d.items: t1 = d1.items
    
16. [c5].Resize(d.Count) = Application.Transpose(k)
    
17. [h5].Resize(d.Count) = Application.Transpose(t)
    
18. 
    
19. For i = 0 To UBound(t1)
    
20.     Cells(i + 5, 4) = Arr(t1(i), 3): Cells(i + 5, 5) = Arr(t1(i), 4): Cells(i + 5, 6) = Arr(t1(i), 5)
    
21.     Cells(i + 5, 7) = Arr(t1(i), 10): Cells(i + 5, 10) = Arr(t1(i), 9)
    
22. Next
    
23. End Sub
    

复制代码

蓝桥玄霜

带条件不重复粘贴汇总.rar (18.24 KB, 下载次数: 17)

2015-11-1 14:11 上传

点击文件名下载附件

请见附件。

sdgyc

蓝桥玄霜 发表于 2015-11-1 14:11
请见附件。

带条件不重复粘贴汇总.rar (405.13 KB, 下载次数: 25)

2015-11-1 17:02 上传

点击文件名下载附件
附件

蓝桥玄霜老师你好!我没有做好表格，麻烦老师重新修改代码，当各店计划表A列和B列增加了内容运行时出错。

蓝桥玄霜

1. Sub lqxs()
   
2. Application.ScreenUpdating = False
   
3. Dim Arr, i&
   
4. Dim d, k, t, d1
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set d1 = CreateObject("Scripting.Dictionary")
   
7. Sheet15.Activate
   
8. [c5:j500].ClearContents
   
9. Arr = Sheet9.[a3].CurrentRegion
   
10. For i = 2 To UBound(Arr)
    
11.     If Arr(i, 17) <= Arr(i, 16) Then
    
12.         d(Arr(i, 3)) = d(Arr(i, 3)) + Arr(i, 13)
    
13.         If Not d1.exists(Arr(i, 3)) Then d1(Arr(i, 3)) = i
    
14.     End If
    
15. Next
    
16. k = d.keys: t = d.items: t1 = d1.items
    
17. [c5].Resize(d.Count) = Application.Transpose(k)
    
18. [h5].Resize(d.Count) = Application.Transpose(t)
    
19. 
    
20. For i = 0 To UBound(t1)
    
21.     Cells(i + 5, 4) = Arr(t1(i), 5): Cells(i + 5, 5) = Arr(t1(i), 6): Cells(i + 5, 6) = Arr(t1(i), 7)
    
22.     Cells(i + 5, 7) = Arr(t1(i), 12): Cells(i + 5, 10) = Arr(t1(i), 11)
    
23. Next
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

sdgyc

蓝桥玄霜 发表于 2015-11-2 11:37

非常感谢蓝桥玄霜老师帮忙！！！

蔡明江

下载学习 有用 谢谢分享解答

wagess

下载学习        谢谢分享