求助，如何能将多个内容汇总在同一单元格里，且按所占比例由大到小列出

chxw68

我猜应该是金额栏有非数字单元格，你试试。

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim r%, i%
   
4.   Dim arr, brr()
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     r = 18
   
8.     arr = .Range("a2:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.Exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       If IsNumeric(arr(i, 3)) Then
    
14.         d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
    
15.       End If
    
16.     Next
    
17.   End With
    
18.   For Each aa In d.Keys
    
19.     hj = Application.Sum(d(aa).Items)
    
20.     If hj <> 0 Then
    
21.       For Each bb In d(aa).Keys
    
22.         If IsNumeric(d(aa)(bb)) Then
    
23.           d(aa)(bb) = d(aa)(bb) / hj
    
24.         End If
    
25.       Next
    
26.     End If
    
27.     kk = d(aa).Keys
    
28.     tt = d(aa).Items
    
29.     For i = 0 To UBound(tt) - 1
    
30.       p = i
    
31.       For j = i + 1 To UBound(tt)
    
32.         If tt(p) < tt(j) Then
    
33.           p = j
    
34.         End If
    
35.       Next
    
36.       If p <> i Then
    
37.         temp = tt(i): tt(i) = tt(p): tt(p) = temp
    
38.         temp = kk(i): kk(i) = kk(p): kk(p) = temp
    
39.       End If
    
40.     Next
    
41.     ss = ""
    
42.     For i = 0 To UBound(kk)
    
43.       ss = ss & "/" & kk(i) & Format(tt(i), "0%")
    
44.     Next
    
45.     d(aa) = Mid(ss, 2)
    
46.   Next
    
47.   ReDim brr(1 To d.Count, 1 To 2)
    
48.   m = 0
    
49.   For Each aa In d.Keys
    
50.     m = m + 1
    
51.     brr(m, 1) = aa
    
52.     brr(m, 2) = d(aa)
    
53.   Next
    
54.   With Worksheets("sheet1")
    
55.     .Range("f1").Resize(UBound(brr), 2) = brr
    
56.   End With
    
57. End Sub
    

复制代码

chxw68

你分析得对！就是字符串超过255个字符了。现在修改好了，连带一些其他出错的可能都纠正了。

bluexuemei

1. Sub t()
   
2. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. y = ojs.eval("def aa(aa);$aa=aa;end")
   
5. y = ojs.Run("aa", Sheet1.Range("a2", [c2].End(4)).Value)
   
6. y = ojs.eval("h={};$aa.map{|x|(h[x[0]]||=[])<<x[1..2]};h.map{|k,v|z=v.map(&:last).reduce(:+);h1=Hash.new(0);v.map{|t|h1[t[0]]+=t[1]};s=h1.map{|k1,v1|[k1,(((v1/z)*100).round)]}.sort_by{|n|-n[1]}.map{|m|m[0]+' '+m[1].to_s+'%'}.join('/');[k,s]}")
   
7. Sheet1.[a30].Resize(UBound(y) + 1, 2) = y
   
8. Set ojs = Nothing
   
9. 'Stop
   
10. End Sub

复制代码

kisses88

chxw68 发表于 2014-12-4 17:42
你分析得对！就是字符串超过255个字符了。现在修改好了，连带一些其他出错的可能都纠正了。

这次完美了。感谢大侠相助，感谢EXCEL HOME~~年末报表多如牛毛啊，没点技巧得死多少回。

wp2002

chxw68 发表于 2014-12-4 17:42
你分析得对！就是字符串超过255个字符了。现在修改好了，连带一些其他出错的可能都纠正了。

请教chxw68大侠，如果想将每一类金额合计也写进去，如何修改代码！