VBA 前三列重复数据去重复,第三列数据求和

qw87887584

前三列去重复 第4列相加,求大神帮忙,得到最右面的数据格式.

多谢大神.

不知道为什么

提问技巧

1.提问之前可以先在论坛搜索相关帖子

2.提问的时候尽量问题说明白点 要有效果图 有表格附件

3.如果别人帮你解决了问题一定要记得回复别人结果 和说声谢谢 有鲜花的话也可以送几朵

4.问题解决后你可以学习别人解决问题的方法

[新手必读]发帖须知、上传附件、截图动画、压缩解压、靓帖推荐：
http://club.excelhome.net/thread-184567-1-1.html

Excel Home论坛学习及使用完全攻略(新人必读)：
http://club.excelhome.net/thread-449518-1-1.html

EH技术论坛的最佳学习方法：
http://club.excelhome.net/thread-117862-1-1.html

jiminyanyan

字典吧。。。。。

wzsy2_mrf

1. 
   
2. Sub kk()
   
3.     Dim d As Object, m%, i%, arr, brr, mkey, j%
   
4.     arr = Sheet1.[A1].CurrentRegion
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     m = 1
   
7.     ReDim brr(1 To 10000, 1 To 4)
   
8.     For i = 2 To UBound(arr)
   
9.         mkey = arr(i, 1) & "++" & arr(i, 2) & "++" & arr(i, 3)
   
10.         If Not d.exists(mkey) Then
    
11.         d(mkey) = m
    
12.         For j = 1 To 4: brr(m, j) = arr(i, j): Next
    
13.         m = m + 1
    
14.         Else
    
15.         brr(d(mkey), 4) = brr(d(mkey), 4) + arr(i, 4)
    
16.         End If
    
17.     Next
    
18.    
    
19.     With Sheet1
    
20.         .Range("h2").Resize(10000, 4).Clear
    
21.         .Range("h2").Resize(d.Count, 4) = brr
    
22.     End With
    
23. End Sub
    

复制代码

amzxfgh9632

1. Sub ???????()
   
2. Dim arr, i%, brr()
   
3. Dim d As Object
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.      xm = arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3)
   
8.      If Not d.exists(xm) Then
   
9.         ReDim brr(1 To 4)
   
10.         brr(1) = arr(i, 1)
    
11.         brr(2) = arr(i, 2)
    
12.         brr(3) = arr(i, 3)
    
13.      Else
    
14.         brr = d(xm)
    
15.      End If
    
16.      brr(4) = brr(4) + arr(i, 4)
    
17.      d(xm) = brr
    
18. Next
    
19. With Sheet2
    
20.     .UsedRange.Offset(2, 0).Clear
    
21.     .Range("A2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
22.   End With
    
23. End Sub

复制代码

张道贤

简单问题复杂化了，数据透视就可以了

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     For i = 1 To UBound(arr)
   
6.         s = arr(i, 1) & arr(i, 2) & arr(i, 3)
   
7.         If Not d.exists(s) Then
   
8.             m = m + 1
   
9.             d(s) = m
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 brr(m, j) = arr(i, j)
    
12.             Next
    
13.         Else
    
14.             brr(d(s), 4) = brr(d(s), 4) + arr(i, 4)
    
15.         End If
    
16.     Next
    
17.     If m Then
    
18.         [h1].CurrentRegion.ClearContents
    
19.         [h1].Resize(m, UBound(brr, 2)) = brr
    
20.     End If
    
21. End Sub

复制代码

lsc900707

附件供测试参考：

shaorenjun888

lsc900707 发表于 2019-3-22 08:39

版主大人，注释下07-14句就好了。

lsc900707

shaorenjun888 发表于 2019-3-22 09:27
版主大人，注释下07-14句就好了。

建议先了解一下字典的基本常识。