求助，如何能将多个内容汇总在同一单元格里，且列出大值

kisses88 · 发表于 2014-1-28 16:55

本帖最后由 kisses88 于 2014-1-28 23:09 编辑

New Microsoft Excel Worksheet.zip (5.43 KB, 下载次数: 21) 需要做一个分析报表，遇到了难题。本人对VBA一无所知。请各位达人看看能否解决？

要求是把客户下的不同类别合并在同一单元格中，并且列出占百分比最高的百分比值。
Microsoft Excel - New Microsoft Excel Worksheet_2014-01-28_16-55-16.png

Microsoft Excel - New Microsoft Excel Worksheet_2014-01-28_16-55-16.png

yjh_27 · 发表于 2014-1-28 17:48

透视表多直观。由透视表得到你要的结果要简单些。

zhaogang1960 · 发表于 2014-1-28 17:52

请测试：

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 & 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
[a30].Resize(d.Count, 2) = brr
End Sub

复制代码

zhaogang1960 · 发表于 2014-1-28 17:53

请看附件

New Microsoft Excel Worksheet.rar (12.22 KB, 下载次数: 34)

kisses88 · 发表于 2014-1-28 18:40

zhaogang1960 发表于 2014-1-28 17:53
请看附件

感谢版主，真的厉害！我先消化消化。。。

kisses88 · 发表于 2014-1-28 21:11

zhaogang1960 发表于 2014-1-28 17:53
请看附件

版主大侠，不知道是不是数据太多了，运行的时候提示溢出。烦请帮忙看看吧。

kisses88 · 发表于 2014-1-28 21:12

运行时提示溢出，为什么呢？？

zhaogang1960 · 发表于 2014-1-28 21:21

kisses88 发表于 2014-1-28 21:12
运行时提示溢出，为什么呢？？

代码没有问题，数据不真实，竟然会有同一个Client合计为0

kisses88 · 发表于 2014-1-28 21:35

zhaogang1960 发表于 2014-1-28 21:21
代码没有问题，数据不真实，竟然会有同一个Client合计为0

可这是真实数据呀。还有合计为负数的呢。因为有退掉的情况。按不同财务月来看就有负数了

zhaogang1960 · 发表于 2014-1-28 21:36

如果你认可一个Client合计为0，可以加一个判断，不加百分数

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

复制代码

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

[已解决] 求助，如何能将多个内容汇总在同一单元格里，且列出大值