如何用VBA实现同列下相同名称值合并，且对应列的值求和汇总

鹦鹉好烦猫

chxw68 发表于 2017-12-20 14:30

大师好 请见附件截图，我把C列排了一下序，就见到C列有很多重复值，我的意思就是想把这些重复项合并，对应G列（工程量）的值也相加汇总，J列（合价）也如此。

鹦鹉好烦猫

liulang0808 发表于 2017-12-20 14:23
请楼主结合附件说明下
目前楼主的需求不是太明白

版主好 请见附件截图，我把C列排了一下序，就见到C列有很多重复值，我的意思就是想把这些重复项合并，对应G列（工程量）的值也相加汇总，J列（合价）也如此。

chxw68

鹦鹉好烦猫 发表于 2017-12-20 15:13
大师好 请见附件截图，我把C列排了一下序，就见到C列有很多重复值，我的意思就是想把这些重复项合并，对 ...

就是这样做的呀！哪儿不对？

liulang0808

1. Sub aaa()
   
2.     arr = Sheets(1).UsedRange
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     a = 2
   
5.     For j = 2 To UBound(arr)
   
6.         If d.exists(arr(j, 3)) Then
   
7.             r = d(arr(j, 3))
   
8.             arr(r, 7) = arr(j, 7) + arr(r, 7)
   
9.             arr(r, 10) = arr(j, 10) + arr(r, 10)
   
10.         Else
    
11.             If a <> j Then
    
12.                 For i = 1 To UBound(arr, 2)
    
13.                     arr(a, i) = arr(j, i)
    
14.                 Next i
    
15.             End If
    
16.             d(arr(j, 3)) = a
    
17.             a = a + 1
    
18.         End If
    
19.     Next j
    
20.     Application.ScreenUpdating = False
    
21.     Sheets(1).Copy after:=Sheets(1)
    
22.     Sheets(2).Name = "结果"
    
23.     Sheets(2).UsedRange.ClearContents
    
24.     Sheets(2).[a1].Resize(a - 1, UBound(arr, 2)) = arr
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

liulang0808

运行代码，生成新表，保存结果，供参考

lsdongjh

会用、善用用新的EXCLE

鹦鹉好烦猫

chxw68 发表于 2017-12-20 15:22
就是这样做的呀！哪儿不对？

大师好 不好意思 看到结果了，是对的，我刚才没表达清楚 ，但是还想请教能不能就直接在原表上运行代码（不需生成新汇总表）？且保留原表的各列，运行后的结果就是只剩下约40多行的汇总表（因为C列重复值都合并了），刚才的代码要怎样改一下？谢谢。

鹦鹉好烦猫

liulang0808 发表于 2017-12-20 15:25
运行代码，生成新表，保存结果，供参考

谢谢版主大师 你的结果正是我想要的 不过因为我刚才没表达清楚意思  所以代码可能要改一改 我正在学习尝试能不能自己改 不行的话就还得请大师帮忙。我是想就直接在原表上运行代码，不生成新汇总表 且保留原表所有列，

liulang0808

1. Sub aaa()
   
2.     arr = Sheets(1).UsedRange
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     a = 2
   
5.     For j = 2 To UBound(arr)
   
6.         If d.exists(arr(j, 3)) Then
   
7.             r = d(arr(j, 3))
   
8.             arr(r, 7) = arr(j, 7) + arr(r, 7)
   
9.             arr(r, 10) = arr(j, 10) + arr(r, 10)
   
10.         Else
    
11.             If a <> j Then
    
12.                 For i = 1 To UBound(arr, 2)
    
13.                     arr(a, i) = arr(j, i)
    
14.                 Next i
    
15.             End If
    
16.             d(arr(j, 3)) = a
    
17.             a = a + 1
    
18.         End If
    
19.     Next j
    
20.     Application.ScreenUpdating = False
    
21.     Sheets(1).UsedRange.ClearContents
    
22.     Sheets(1).[a1].Resize(a - 1, UBound(arr, 2)) = arr
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    

复制代码

liulang0808

供参考。。。。。。