来个高手帮忙写个代码，自己卡在合并相同项了。

shangfgf

想达到的目的是，对图纸编号相同的，要求只保留一个，但是数量要相加。自己写了一个目的是达到了，但是在数据较多的时候，速度有点慢，麻烦高手帮忙写个速度快一点啊！ 图纸清单.zip (10.57 KB, 下载次数: 3)

2018-9-15 15:42 上传

点击文件名下载附件

liulang0808

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     Set Rng = Nothing
   
6.     For j = 2 To UBound(arr)
   
7.         If Len(arr(j, 1)) > 0 Then
   
8.             If d.exists(arr(j, 1)) Then
   
9.                 arr(d(arr(j, 1)), 5) = arr(j, 5) + arr(d(arr(j, 1)), 5)
   
10.                 If Rng Is Nothing Then
    
11.                     Set Rng = Cells(j, 1)
    
12.                 Else
    
13.                     Set Rng = Union(Rng, Cells(j, 1))
    
14.                 End If
    
15.             Else
    
16.                 d(arr(j, 1)) = j
    
17.             End If
    
18.         End If
    
19.     Next j
    
20.     [a1].CurrentRegion = arr
    
21.     If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
22.     Application.ScreenUpdating = True
    
23. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

shangfgf

liulang0808 发表于 2018-9-15 16:13
附件内容供参考。。。。。。

感谢，空了我去试试。