设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

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

[求助] 一维转二维,并排名

[复制链接]
amzxfgh9632

TA的精华主题

TA的得分主题
发表于 2024-7-11 16:06 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
将左边数据转成右边效果，增加总分并按年级计算各科成绩排名（中国式） 一维表转二维表.zip (19.31 KB, 下载次数: 39)
回复

举报

ykcbf1100

TA的精华主题

TA的得分主题
发表于 2024-7-11 16:11 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
有点繁，先标记一下吧。
回复

举报

lsc900707

TA的精华主题

TA的得分主题
发表于 2024-7-11 16:47 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
一个小学生的成绩搞那么多的排名？
回复

举报

amzxfgh9632

TA的精华主题

TA的得分主题
 楼主| 发表于 2024-7-11 16:48 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
lsc900707 发表于 2024-7-11 16:47
一个小学生的成绩搞那么多的排名？

其实是中考或高考的，这只是一个实例
回复

举报

边缘码农

TA的精华主题

TA的得分主题
发表于 2024-7-11 16:58 | 显示全部楼层
[广告] ★ 造就Excel高手的神器，远胜VBA/Python ★
这个其实是可以用公式解决的。
回复

举报

liuyu5863016

TA的精华主题

TA的得分主题
发表于 2024-7-11 17:18 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
前半部分先做出来了
  1. Sub t()

  3.     Dim d1 As Object, d2 As Object
  4.     Dim ws As Worksheet, rng As Range
  5.     Dim source_arr, kemu_arr
  6.     Dim i%, j%, l%
  7.     Dim k1, k2
  8.     Dim sum
  9.    
  10.     ' 基础数据源
  11.     Set d1 = CreateObject("scripting.dictionary")
  12.     Set d2 = CreateObject("scripting.dictionary")
  13.     Set ws = Worksheets("成绩表")
  14.     source_arr = ws.Range("A1").CurrentRegion
  15.    
  16.     ' d1生成基础信息：key：考号，item：年经&姓名
  17.     ' d2生成科目
  18.     For i = 2 To UBound(source_arr)
  19.         d1.Item(source_arr(i, 2)) = source_arr(i, 1) & "," & source_arr(i, 3)
  20.         d2.Item(source_arr(i, 4)) = source_arr(i, 4)
  21.     Next i
  22.    
  23.     ReDim kemu_arr(1 To d1.Count, 1 To d2.Count + 4)
  24.    
  25.     For Each k1 In d1.keys
  26.         l = l + 1
  27.         j = 3
  28.         sum = 0
  29.         kemu_arr(l, 2) = k1
  30.         kemu_arr(l, 1) = Split(d1.Item(k1), ",")(0)
  31.         kemu_arr(l, 1) = Split(d1.Item(k1), ",")(1)
  32.         For Each k2 In d2.keys
  33.             j = j + 1
  34.             For i = 2 To UBound(source_arr)
  35.                 If source_arr(i, 2) = k1 Then
  36.                     If source_arr(i, 4) = k2 Then
  37.                         kemu_arr(l, j) = source_arr(i, 5)
  38.                         sum = sum + source_arr(i, 5)
  39.                         Exit For
  40.                     End If
  41.                 End If
  42.             Next i
  43.         Next k2
  44.         kemu_arr(l, UBound(kemu_arr, 2)) = sum
  45.     Next k1
  46.    
  47.     ' 工作表写入
  48.     ws.Range("a1:c1").Copy ws.Range("r23")
  49.     ws.Range("u23").Resize(, d2.Count) = d2.items
  50.     ws.Range("r24").Resize(d1.Count, d2.Count + 4) = kemu_arr
  51.    
  52. End Sub
复制代码

image.png
回复

举报

sxbjzjf110

TA的精华主题

TA的得分主题
发表于 2024-7-11 17:41 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
留个记号，有时间看看。
回复

举报

一招秒杀

TA的精华主题

TA的得分主题
发表于 2024-7-11 17:42 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
1条语句，瞬间秒杀。
中国式排名.png

评分

1

查看全部评分

回复

举报

剑指E

TA的精华主题

TA的得分主题
发表于 2024-7-11 17:44 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
  1. =LET(ar,UNIQUE(A2:C61),cr,TOROW(UNIQUE(D2:D61)),dr,SUMIFS(E:E,A:A,INDEX(ar,,1),B:B,INDEX(ar,,2),C:C,INDEX(ar,,3),D:D,HSTACK(cr,"*")),br,DROP(REDUCE(0,SEQUENCE(COUNTA(cr)+1),LAMBDA(x,y,HSTACK(x,LET(_a,INDEX(dr,,y),MATCH(_a,SORT(UNIQUE(_a),,-1),))))),,1),er,IFNA(HSTACK({"年级","考号","姓名";"","",""},VSTACK({"","","考试科目"},cr),"总分",IFNA(HSTACK(cr,{"总分";"排名"}),"排名")),""),VSTACK(er,HSTACK(ar,dr,br)))
复制代码

评分

1

查看全部评分

回复

举报

liuyu5863016

TA的精华主题

TA的得分主题
发表于 2024-7-11 17:45 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
下班了，做了一半出来
  1. Sub t()

  3.     Dim d1 As Object, d2 As Object
  4.     Dim ws As Worksheet, rng As Range
  5.     Dim source_arr, kemu_arr
  6.     Dim i%, j%, l%
  7.     Dim k1, k2
  8.     Dim sum
  9.    
  10.     ' 基础数据源
  11.     Set d1 = CreateObject("scripting.dictionary")
  12.     Set d2 = CreateObject("scripting.dictionary")
  13.     Set ws = Worksheets("成绩表")
  14.     source_arr = ws.Range("A1").CurrentRegion
  15.    
  16.     ' d1生成基础信息：key：考号，item：年经&姓名
  17.     ' d2生成科目
  18.     For i = 2 To UBound(source_arr)
  19.         d1.Item(source_arr(i, 2)) = source_arr(i, 1) & "," & source_arr(i, 3)
  20.         d2.Item(source_arr(i, 4)) = source_arr(i, 4)
  21.     Next i
  22.    
  23.     ReDim kemu_arr(1 To d1.Count, 1 To d2.Count + 4)
  24.    
  25.     For Each k1 In d1.keys
  26.         l = l + 1
  27.         j = 3
  28.         sum = 0
  29.         kemu_arr(l, 2) = k1
  30.         kemu_arr(l, 1) = Split(d1.Item(k1), ",")(0)
  31.         kemu_arr(l, 3) = Split(d1.Item(k1), ",")(1)
  32.         For Each k2 In d2.keys
  33.             j = j + 1
  34.             For i = 2 To UBound(source_arr)
  35.                 If source_arr(i, 2) = k1 Then
  36.                     If source_arr(i, 4) = k2 Then
  37.                         kemu_arr(l, j) = source_arr(i, 5)
  38.                         sum = sum + source_arr(i, 5)
  39.                         Exit For
  40.                     End If
  41.                 End If
  42.             Next i
  43.         Next k2
  44.         kemu_arr(l, UBound(kemu_arr, 2)) = sum
  45.     Next k1
  46.    
  47.     ' 工作表写入
  48.     ws.Range("a1:c1").Copy ws.Range("r23")
  49.     ws.Range("u23").Resize(, d2.Count) = d2.items
  50.     ws.Range("r24").Resize(d1.Count, d2.Count + 4) = kemu_arr
  51.    
  52. End Sub
复制代码

image.png

评分

1

查看全部评分

回复

举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-11-18 01:30 , Processed in 0.036430 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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