Excel如何實現多行合併成一行合計？

wei48165

如上圖，如何把相同C列合併成一行，且D列去掉後面S、R也合併成一行，E列合計，請教各位大神 如何實現。。。

test4.rar (3.28 KB, 下载次数: 10)

2013-12-12 15:53 上传

点击文件名下载附件

MicrosoftEH

这个太难了吧

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, aa, Brr
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = [c1].CurrentRegion
   
7. [c9:e500].Clear
   
8. For i = 1 To UBound(Arr)
   
9.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
   
10. Next
    
11. k = d.keys: t = d.items
    
12. ReDim Brr(1 To d.Count, 1 To UBound(Arr, 2))
    
13. For i = 0 To UBound(k)
    
14.     t(i) = Left(t(i), Len(t(i)) - 1)
    
15.     Brr(i + 1, 1) = k(i)
    
16.     If InStr(t(i), ",") Then
    
17.         aa = Split(t(i), ",")
    
18.         For j = 0 To UBound(aa)
    
19.             If Brr(i + 1, 2) = "" Then
    
20.                 Brr(i + 1, 2) = Arr(aa(j), 2)
    
21.             Else
    
22.                 Brr(i + 1, 2) = Brr(i + 1, 2) & "" & Arr(aa(j), 2)
    
23.             End If
    
24.             Brr(i + 1, 3) = Brr(i + 1, 3) + Arr(aa(j), 3)
    
25.         Next
    
26.     Else
    
27.     End If
    
28. Next
    
29. [c9].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
30. [c9].Resize(UBound(Brr), UBound(Brr, 2)).Borders.LineStyle = 1
    
31. End Sub
    

复制代码

蓝桥玄霜

请见附件。

grf1973

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [c1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 3)
   
5.     For i = 1 To UBound(arr)
   
6.         pm = arr(i, 1)
   
7.         pd = arr(i, 2)
   
8.         pd = Left(pd, 4)
   
9.         If Not d.exists(pm) Then
   
10.             n = n + 1
    
11.             d(pm) = n
    
12.             brr(n, 1) = pm
    
13.         End If
    
14.         k = d(pm)
    
15.         brr(k, 3) = brr(k, 3) + arr(i, 3)
    
16.         If brr(k, 2) = "" Then brr(k, 2) = pd
    
17.         If InStr(brr(k, 2), pd) = 0 Then brr(k, 2) = brr(k, 2) & "/" & pd
    
18.     Next
    
19.     [c9].Resize(n, 3) = brr
    
20. End Sub
    

复制代码

grf1973

请看附件。

wei48165

蓝桥玄霜 发表于 2013-12-12 16:11

大神，可以用函數實現麼，這樣好引用些...
對了，後面的包含的某個字符，如S ,R ，可以去掉麼...多謝

wei48165

grf1973 发表于 2013-12-12 16:16

大神可以幫忙改寫成函數嗎？多謝...

wei48165

grf1973 发表于 2013-12-12 16:16

pd = Left(pd, 4)

大神，你这是取的定长....
如果想包含 ‘S’，‘R’，则去掉后缀，怎么实现啊。。。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, aa, Brr
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = [c1].CurrentRegion
   
7. [c9:e500].Clear
   
8. For i = 1 To UBound(Arr)
   
9.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
   
10. Next
    
11. k = d.keys: t = d.items
    
12. ReDim Brr(1 To d.Count, 1 To UBound(Arr, 2))
    
13. d.RemoveAll
    
14. For i = 0 To UBound(k)
    
15.     t(i) = Left(t(i), Len(t(i)) - 1)
    
16.     Brr(i + 1, 1) = k(i)
    
17.     If InStr(t(i), ",") Then
    
18.         aa = Split(t(i), ",")
    
19.         For j = 0 To UBound(aa)
    
20.             x = Left(Arr(aa(j), 2), 4)
    
21.             If Brr(i + 1, 2) = "" Then
    
22.                 If Not d.exists(x) Then
    
23.                     d(x) = ""
    
24.                     Brr(i + 1, 2) = x
    
25.                 End If
    
26.             Else
    
27.                 If Not d.exists(x) Then
    
28.                     d(x) = ""
    
29.                     Brr(i + 1, 2) = Brr(i + 1, 2) & "/" & x
    
30.                 End If
    
31.             End If
    
32.             Brr(i + 1, 3) = Brr(i + 1, 3) + Arr(aa(j), 3)
    
33.         Next
    
34.     Else
    
35.     End If
    
36. d.RemoveAll
    
37. Next
    
38. [c9].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
39. [c9].Resize(UBound(Brr), UBound(Brr, 2)).Borders.LineStyle = 1
    
40. End Sub
    

复制代码