[已解决]求版主受累给写一段吧，万分感谢啊

holidaysh

还是刚才的问题，把D列中相同的料号，在H列中进行数量加总，并删除D列中重复料号所在的行，然后把新的全部内容（包括ABCE等其他列）复制到SHEET2中，求代码，谢谢！！急用！！！

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2012-10-29 17:10

1. Sub lqxs()
   
2. Dim Arr, i&, d, rng As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheet1.Activate
   
5. Arr = [a1].CurrentRegion
   
6. For i = 2 To UBound(Arr)
   
7.     If Not d.exists(Arr(i, 4)) Then
   
8.         d(Arr(i, 4)) = Arr(i, 8)
   
9.         If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
   
10.     Else
    
11.         d(Arr(i, 4)) = d(Arr(i, 4)) + Arr(i, 8)
    
12.     End If
    
13. Next
    
14. Sheet2.[a1].Resize(1, UBound(Arr, 2)) = Application.Index(Arr, 1, 0)
    
15. If Not rng Is Nothing Then rng.Copy Sheet2.[a2]
    
16. Sheet2.[h2].Resize(d.Count) = Application.Transpose(d.items)
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, d, rng As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheet1.Activate
   
5. Arr = [a1].CurrentRegion
   
6. For i = 2 To UBound(Arr)
   
7.     If Not d.exists(Arr(i, 4)) Then
   
8.         d(Arr(i, 4)) = Arr(i, 8)
   
9.         If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
   
10.     Else
    
11.         d(Arr(i, 4)) = d(Arr(i, 4)) + Arr(i, 8)
    
12.     End If
    
13. Next
    
14. Sheet2.[a1].Resize(1, UBound(Arr, 2)) = Application.Index(Arr, 1, 0)
    
15. If Not rng Is Nothing Then rng.Copy Sheet2.[a2]
    
16. Sheet2.[h2].Resize(d.Count) = Application.Transpose(d.items)
    
17. End Sub
    

复制代码

蓝桥玄霜

表1没有删除重复的，请见附件。