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

kisses88 · 发表于 2014-12-4 15:34

本帖最后由 kisses88 于 2014-12-4 15:42 编辑

Microsoft Excel - 问题二 [Compatibility Mode]_2014-12-04_15-32-52.png

问题二.zip (7.48 KB, 下载次数: 4)

之前曾经在版主帮忙下解决掉的问题有了进阶版，烦请各位达人看看应该如何解决。万分感激。
大家可参考之前的帖子。
http://club.excelhome.net/thread-1092153-1-1.html

下面是以前的代码，不知是否可以修改一下来实现现在这个问题？但我自己真不知道该怎么改。T O T

Sub Macro1()
Dim arr, brr(), i&, j&, v&, m#, k, t, k2, t2, s$, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
ds(arr(i, 1)) = ds(arr(i, 1)) + arr(i, 3)
Next
k = d.keys
t = ds.items
ReDim brr(0 To d.Count - 1, 1 To 2)
With WorksheetFunction
For i = 0 To d.Count - 1
brr(i, 1) = k(i)
k2 = d(k(i)).keys
t2 = d(k(i)).items
m = .Max(t2)
v = .Match(m, t2, 0) - 1
s = k2(v)
brr(i, 2) = s
If t(i) <> 0 Then brr(i, 2) = brr(i, 2) & Format(m / t(i), "0%") & Chr(10)
For j = 0 To UBound(t2)
If j <> v Then brr(i, 2) = brr(i, 2) & "/" & k2(j)
Next
Next
End With
[k10].Resize(d.Count, 2) = brr
End Sub

复制代码

chxw68 · 发表于 2014-12-4 15:45

Sub test()
Dim d As New Dictionary
Dim r%, i%
Dim arr, brr()
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
r = 18
arr = .Range("a2:c" & r)
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
Next
End With
For Each aa In d.Keys
hj = Application.Sum(d(aa).Items)
ss = ""
For Each bb In d(aa).Keys
ss = ss & "/" & bb & Format(d(aa)(bb) / hj, "0%")
Next
d(aa) = Mid(ss, 2)
Next
With Worksheets("sheet1")
.Range("f1").Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))
End With
tt = d.Items
End Sub

复制代码

chxw68 · 发表于 2014-12-4 15:46

这道题用字典嵌套做很方便。

chxw68 · 发表于 2014-12-4 15:53

呵呵，二楼代码忘了排序了。

Sub test()
Dim d As New Dictionary
Dim r%, i%
Dim arr, brr()
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
r = 18
arr = .Range("a2:c" & r)
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
Next
End With
For Each aa In d.Keys
hj = Application.Sum(d(aa).Items)
For Each bb In d(aa).Keys
d(aa)(bb) = d(aa)(bb) / hj
Next
kk = d(aa).Keys
tt = d(aa).Items
For i = 0 To UBound(tt) - 1
p = i
For j = i + 1 To UBound(tt)
If tt(p) < tt(j) Then
p = j
End If
Next
If p <> i Then
temp = tt(i): tt(i) = tt(p): tt(p) = temp
temp = kk(i): kk(i) = kk(p): kk(p) = temp
End If
Next
ss = ""
For i = 0 To UBound(kk)
ss = ss & "/" & kk(i) & Format(tt(i), "0%")
Next
d(aa) = Mid(ss, 2)
Next
With Worksheets("sheet1")
.Range("f1").Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))
End With
tt = d.Items
End Sub

复制代码

chxw68 · 发表于 2014-12-4 15:54

二楼代码忘了排序了。

kisses88 · 发表于 2014-12-4 15:54

chxw68 发表于 2014-12-4 15:46
这道题用字典嵌套做很方便。

感谢大神，这么快回复了。可是好像没有按百分比由大到小自动排序。

kisses88 · 发表于 2014-12-4 15:57

chxw68 发表于 2014-12-4 15:54
二楼代码忘了排序了。

感谢哈！纠结我大半天问题这么快解决了。

kisses88 · 发表于 2014-12-4 16:21

chxw68 发表于 2014-12-4 15:54
二楼代码忘了排序了。

大侠，超过18行怎么办？

kisses88 · 发表于 2014-12-4 17:00

本帖最后由 kisses88 于 2014-12-4 20:30 编辑

chxw68 发表于 2014-12-4 15:54
二楼代码忘了排序了。

可能是因为TYPE字符太多了，运行的时候提示这个。能怎么解决？

kisses88 · 发表于 2014-12-4 17:30

本帖最后由 kisses88 于 2014-12-4 20:31 编辑

kisses88 发表于 2014-12-4 17:00
可能是因为TYPE字符太多了，运行的时候提示这个。能怎么解决？

请检查，应该是字符串超过了255，T ^ T...

		自动登录	找回密码
密码			免费注册

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

点评

点评

点评