ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2197|回复: 15

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 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

TA的精华主题

TA的得分主题

发表于 2014-1-28 17:48 | 显示全部楼层
透视表多直观。由透视表得到你要的结果要简单些。

TA的精华主题

TA的得分主题

发表于 2014-1-28 17:52 | 显示全部楼层
请测试:
  1. Sub Macro1()
  2.     Dim arr, brr(), i&, j&, v&, m#, k, t, k2, t2, s$, d As Object, ds As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set ds = CreateObject("scripting.dictionary")
  5.     arr = Range("A1").CurrentRegion
  6.     For i = 2 To UBound(arr)
  7.         If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
  8.         d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
  9.         ds(arr(i, 1)) = ds(arr(i, 1)) + arr(i, 3)
  10.     Next
  11.     k = d.keys
  12.     t = ds.items
  13.     ReDim brr(0 To d.Count - 1, 1 To 2)
  14.     With WorksheetFunction
  15.     For i = 0 To d.Count - 1
  16.         brr(i, 1) = k(i)
  17.         k2 = d(k(i)).keys
  18.         t2 = d(k(i)).items
  19.         m = .Max(t2)
  20.         v = .Match(m, t2, 0) - 1
  21.         s = k2(v)
  22.         brr(i, 2) = s & Format(m / t(i), "0%") & Chr(10)
  23.         For j = 0 To UBound(t2)
  24.             If j <> v Then brr(i, 2) = brr(i, 2) & "/" & k2(j)
  25.         Next
  26.     Next
  27.     End With
  28.     [a30].Resize(d.Count, 2) = brr
  29. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2014-1-28 17:53 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
请看附件
New Microsoft Excel Worksheet.rar (12.22 KB, 下载次数: 35)

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-1-28 18:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
zhaogang1960 发表于 2014-1-28 17:53
请看附件

感谢版主,真的厉害!我先消化消化。。。

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-1-28 21:11 | 显示全部楼层
zhaogang1960 发表于 2014-1-28 17:53
请看附件

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-1-28 21:12 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
运行时提示溢出,为什么呢??

2.zip

978 KB, 下载次数: 11

TA的精华主题

TA的得分主题

发表于 2014-1-28 21:21 | 显示全部楼层
kisses88 发表于 2014-1-28 21:12
运行时提示溢出,为什么呢??

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-1-28 21:35 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
zhaogang1960 发表于 2014-1-28 21:21
代码没有问题,数据不真实,竟然会有同一个Client合计为0

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

TA的精华主题

TA的得分主题

发表于 2014-1-28 21:36 | 显示全部楼层
如果你认可一个Client合计为0,可以加一个判断,不加百分数
  1. Sub Macro1()
  2.     Dim arr, brr(), i&, j&, v&, m#, k, t, k2, t2, s$, d As Object, ds As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set ds = CreateObject("scripting.dictionary")
  5.     arr = Range("A1").CurrentRegion
  6.     For i = 2 To UBound(arr)
  7.         If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
  8.         d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
  9.         ds(arr(i, 1)) = ds(arr(i, 1)) + arr(i, 3)
  10.     Next
  11.     k = d.keys
  12.     t = ds.items
  13.     ReDim brr(0 To d.Count - 1, 1 To 2)
  14.     With WorksheetFunction
  15.     For i = 0 To d.Count - 1
  16.         brr(i, 1) = k(i)
  17.         k2 = d(k(i)).keys
  18.         t2 = d(k(i)).items
  19.         m = .Max(t2)
  20.         v = .Match(m, t2, 0) - 1
  21.         s = k2(v)
  22.         brr(i, 2) = s
  23.         If t(i) <> 0 Then brr(i, 2) = brr(i, 2) & Format(m / t(i), "0%") & Chr(10)
  24.         For j = 0 To UBound(t2)
  25.             If j <> v Then brr(i, 2) = brr(i, 2) & "/" & k2(j)
  26.         Next
  27.     Next
  28.     End With
  29.     [k10].Resize(d.Count, 2) = brr
  30. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-22 06:01 , Processed in 0.044840 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表