ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 怎么用VBA获取excell中的指定规则来排序

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-10-28 20:19 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:排序和排名
如图,按照 Sheet2里的规则,对Sheet1里的内容进行排序。请高手帮帮忙{:soso_e154:}
1.jpg
2.jpg


附件:
指定规则排序.rar (7.24 KB, 下载次数: 71)

TA的精华主题

TA的得分主题

发表于 2013-10-28 21:18 | 显示全部楼层
本帖最后由 zhaogang1960 于 2013-10-28 21:21 编辑

按照Sheet2中B列循序排序,如果是请测试:
  1. Sub 宏1()
  2.     Dim arr
  3.     arr = Sheets("Sheet2").Range("B1:B" & Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row)
  4.     Application.AddCustomList ListArray:=arr
  5.     Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Header:=xlYes, _
  6.                 OrderCustom:=Application.CustomListCount + 1
  7.     Application.DeleteCustomList ListNum:=Application.CustomListCount
  8. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2013-10-28 21:21 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
请看附件
指定规则排序.rar (17.06 KB, 下载次数: 105)

TA的精华主题

TA的得分主题

发表于 2013-10-28 22:03 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr, crr, d As Object, i&, j&, k&, s&, y&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Sheet1.Range("a1").CurrentRegion
  5. crr = arr
  6. brr = Sheet2.Range("a1").CurrentRegion
  7. y = UBound(brr)
  8. For i = 2 To UBound(arr)
  9.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
  10. Next
  11. For i = 1 To UBound(brr)
  12.     x = Split(Mid(d(brr(i, 2)), 2), ",")
  13.     s = 0
  14.     For j = 0 To UBound(x)
  15.         s = j * y + i + 1
  16.         For k = 1 To UBound(arr, 2)
  17.             crr(s, k) = arr(x(j), k)
  18.         Next
  19.     Next
  20. Next
  21. Range("f1").Resize(UBound(crr), UBound(crr, 2)) = crr
  22. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2013-10-28 22:05 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
………………

指定规则排序.zip

10.81 KB, 下载次数: 39

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-10-29 08:37 | 显示全部楼层
zhaogang1960 发表于 2013-10-28 21:18
按照Sheet2中B列循序排序,如果是请测试:

受教了。测试了下,在Sheet2.B列里增加内容也可以自动排序,很强大,非常感谢。

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-10-29 08:38 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
dsmch 发表于 2013-10-28 22:03

看了下效果,最后结果是按学期来排序了,不是我要的效果哦。不过还是非常感觉您的帮忙。

TA的精华主题

TA的得分主题

发表于 2013-10-29 11:49 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
jnear 发表于 2013-10-29 08:38
看了下效果,最后结果是按学期来排序了,不是我要的效果哦。不过还是非常感觉您的帮忙。
  1. Sub Macro1()
  2. Dim arr, brr, crr, d As Object, i&, j&, k&, s&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Sheet1.Range("a1").CurrentRegion
  5. crr = arr
  6. brr = Sheet2.Range("a1").CurrentRegion
  7. For i = 2 To UBound(arr)
  8.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
  9. Next
  10. s = 1
  11. For i = 1 To UBound(brr)
  12.     x = Split(Mid(d(brr(i, 2)), 2), ",")
  13.     For j = 0 To UBound(x)
  14.         s = s + 1
  15.         For k = 1 To UBound(arr, 2)
  16.             crr(s, k) = arr(x(j), k)
  17.         Next
  18.     Next
  19. Next
  20. Range("f1").Resize(UBound(crr), UBound(crr, 2)) = crr
  21. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2013-10-29 11:51 | 显示全部楼层
……………………

指定规则排序.zip

10.71 KB, 下载次数: 33

TA的精华主题

TA的得分主题

发表于 2014-9-29 14:51 | 显示全部楼层
zhaogang1960 发表于 2013-10-28 21:18
按照Sheet2中B列循序排序,如果是请测试:

请教:按C列数字大小排呢?谢谢!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-28 19:33 , Processed in 0.050209 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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