设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 有关文本与数字混合排序
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2728|回复: 8

[已解决]有关文本与数字混合排序

[复制链接]
发表于 2015-4-11 18:13 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 张雄友 于 2015-6-8 07:49 编辑

有关文本与数字混合排序。文本就是（纯文本，文本与字母组成的），混合就是（文本与数字一起组成的）。
最佳答案
月排行榜 / 总排行榜
dsmch
2015-6-8 07:03
  1. Sub TranForm加个总计()
  2. Dim arr, brr, crr, d, d2, d3, d4, i&, j%, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. Set d4 = CreateObject("scripting.dictionary")
  7. arr = [b3:f19]
  8. With CreateObject("vbscript.regexp")
  9.     .Pattern = "[a-zA-Z]+"
  10.     .Global = True
  11.     For i = 1 To UBound(arr)
  12.         d4(arr(i, 1)) = ""
  13.         Set ms = .Execute(arr(i, 1))
  14.         If ms(0) = arr(i, 1) Then
  15.             If Not d.exists(arr(i, 2)) Then d(arr(i, 2)) = ""
  16.         Else
  17.             arr(i, 2) = "区域工序" & Format(Mid(arr(i, 2), 5), "00")
  18.             If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = ""
  19.         End If
  20.         zf = arr(i, 1) & "," & arr(i, 2)
  21.         d3(zf) = d3(zf) + arr(i, 5)
  22.     Next
  23. End With
  24. Set rng = Cells(2, Range("k2").Column + d.Count)
  25. rng.Resize(1, d2.Count) = d2.keys
  26. rng.Resize(1, d2.Count).Sort rng, Header:=xlGuess, Orientation:=xlLeftToRight, _
  27.         SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  28. Range("k2").Resize(1, d.Count) = d.keys
  29. [j2] = "制单号": rng.Offset(0, d2.Count) = "总计"
  30. brr = [j2].CurrentRegion
  31. ReDim crr(1 To d4.Count + 1, 1 To UBound(brr, 2))
  32. a = d4.keys: crr(d4.Count + 1, 1) = "总计"
  33. For i = 0 To d4.Count - 1
  34.     crr(i + 1, 1) = a(i): s = 0
  35.     For j = 2 To UBound(brr, 2) - 1
  36.         zf = a(i) & "," & brr(1, j)
  37.         crr(i + 1, j) = d3(zf)
  38.         s = s + Val(crr(i + 1, j))
  39.         crr(UBound(crr), j) = crr(UBound(crr), j) + Val(crr(i + 1, j))
  40.     Next
  41.     crr(i + 1, UBound(brr, 2)) = s
  42.     s2 = s2 + s
  43. Next
  44. crr(UBound(crr), UBound(crr, 2)) = s2
  45. [j3].Resize(UBound(crr), UBound(crr, 2)) = crr
  46. End Sub
复制代码

正则排序3.rar

12.55 KB, 下载次数: 29
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
dsmch
发表于 2015-6-7 17:10 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
如标题不确定
  1. Sub Macro1()
  2. Dim arr, brr, crr, d, d2, d3, d4, i&, j%, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. Set d4 = CreateObject("scripting.dictionary")
  7. arr = [b3:f19]
  8. With CreateObject("vbscript.regexp")
  9.     .Pattern = "[a-zA-Z]+"
  10.     .Global = True
  11.     For i = 1 To UBound(arr)
  12.         d4(arr(i, 1)) = ""
  13.         zf = arr(i, 1) & "," & arr(i, 2)
  14.         d3(zf) = d3(zf) + arr(i, 5)
  15.         Set ms = .Execute(arr(i, 1))
  16.         If ms(0) = arr(i, 1) Then
  17.             If Not d.exists(arr(i, 2)) Then d(arr(i, 2)) = ""
  18.         Else
  19.             If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = ""
  20.         End If
  21.     Next
  22. End With
  23. Set rng = Cells(2, Range("k2").Column + d.Count)
  24. rng.Resize(1, d2.Count) = d2.keys
  25. rng.Resize(1, d2.Count).Sort rng, Header:=xlGuess, Orientation:=xlLeftToRight, _
  26.         SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  27. Range("k2").Resize(1, d.Count) = d.keys
  28. [j2] = "制单号"
  29. brr = [j2].CurrentRegion
  30. ReDim crr(1 To d4.Count, 1 To UBound(brr, 2))
  31. a = d4.keys
  32. For i = 0 To d4.Count - 1
  33.     crr(i + 1, 1) = a(i)
  34.     For j = 2 To UBound(brr, 2)
  35.         zf = a(i) & "," & brr(1, j)
  36.         crr(i + 1, j) = d3(zf)
  37.     Next
  38. Next
  39. [j3].Resize(UBound(crr), UBound(crr, 2)) = crr
  40. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-6-7 21:22 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
dsmch 发表于 2015-6-7 17:10
如标题不确定

行列加个总计就好了。

正则排序.rar

12.78 KB, 下载次数: 3
回复

使用道具 举报

dsmch
发表于 2015-6-7 22:27 | 显示全部楼层
  1. Sub TranForm()
  2. Dim arr, brr, crr, d, d2, d3, d4, i&, j%, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. Set d4 = CreateObject("scripting.dictionary")
  7. arr = [b3:f19]
  8. With CreateObject("vbscript.regexp")
  9.     .Pattern = "[a-zA-Z]+"
  10.     .Global = True
  11.     For i = 1 To UBound(arr)
  12.         d4(arr(i, 1)) = ""
  13.         zf = arr(i, 1) & "," & arr(i, 2)
  14.         d3(zf) = d3(zf) + arr(i, 5)
  15.         Set ms = .Execute(arr(i, 1))
  16.         If ms(0) = arr(i, 1) Then
  17.             If Not d.exists(arr(i, 2)) Then d(arr(i, 2)) = ""
  18.         Else
  19.             If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = ""
  20.         End If
  21.     Next
  22. End With
  23. Set rng = Cells(2, Range("k2").Column + d.Count)
  24. rng.Resize(1, d2.Count) = d2.keys
  25. rng.Resize(1, d2.Count).Sort rng, Header:=xlGuess, Orientation:=xlLeftToRight, _
  26.         SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  27. Range("k2").Resize(1, d.Count) = d.keys
  28. [j2] = "制单号": rng.Offset(0, d2.Count) = "总计"
  29. brr = [j2].CurrentRegion
  30. ReDim crr(1 To d4.Count + 1, 1 To UBound(brr, 2))
  31. 'ReDim w(2 To UBound(brr, 2))
  32. a = d4.keys: crr(d4.Count + 1, 1) = "总计"
  33. For i = 0 To d4.Count - 1
  34.     crr(i + 1, 1) = a(i): s = 0
  35.     For j = 2 To UBound(brr, 2) - 1
  36.         zf = a(i) & "," & brr(1, j)
  37.         crr(i + 1, j) = d3(zf)
  38.         s = s + Val(crr(i + 1, j))
  39.         crr(UBound(crr), j) = crr(UBound(crr), j) + Val(crr(i + 1, j))
  40.     Next
  41.     crr(i + 1, UBound(brr, 2)) = s
  42.     s2 = s2 + s
  43. Next
  44. crr(UBound(crr), UBound(crr, 2)) = s2
  45. [j3].Resize(UBound(crr), UBound(crr, 2)) = crr
  46. End Sub
复制代码

点评

张雄友
您的意思是数字的长度要一致：如：05，45，这样才能排序？  发表于 2015-6-8 06:54
回复

使用道具 举报

 楼主| 发表于 2015-6-8 06:34 | 显示全部楼层
dsmch 发表于 2015-6-7 22:27

有数字的从小到大，没有实现到。
区域工序45
区域工序5

顺序不对。

正则排序2.rar

14.18 KB, 下载次数: 2

点评

dsmch
源数据要规范，如凭证001，凭证123  发表于 2015-6-8 06:51
回复

使用道具 举报

dsmch
发表于 2015-6-8 07:03 | 显示全部楼层    本楼为最佳答案   
  1. Sub TranForm加个总计()
  2. Dim arr, brr, crr, d, d2, d3, d4, i&, j%, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. Set d4 = CreateObject("scripting.dictionary")
  7. arr = [b3:f19]
  8. With CreateObject("vbscript.regexp")
  9.     .Pattern = "[a-zA-Z]+"
  10.     .Global = True
  11.     For i = 1 To UBound(arr)
  12.         d4(arr(i, 1)) = ""
  13.         Set ms = .Execute(arr(i, 1))
  14.         If ms(0) = arr(i, 1) Then
  15.             If Not d.exists(arr(i, 2)) Then d(arr(i, 2)) = ""
  16.         Else
  17.             arr(i, 2) = "区域工序" & Format(Mid(arr(i, 2), 5), "00")
  18.             If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = ""
  19.         End If
  20.         zf = arr(i, 1) & "," & arr(i, 2)
  21.         d3(zf) = d3(zf) + arr(i, 5)
  22.     Next
  23. End With
  24. Set rng = Cells(2, Range("k2").Column + d.Count)
  25. rng.Resize(1, d2.Count) = d2.keys
  26. rng.Resize(1, d2.Count).Sort rng, Header:=xlGuess, Orientation:=xlLeftToRight, _
  27.         SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  28. Range("k2").Resize(1, d.Count) = d.keys
  29. [j2] = "制单号": rng.Offset(0, d2.Count) = "总计"
  30. brr = [j2].CurrentRegion
  31. ReDim crr(1 To d4.Count + 1, 1 To UBound(brr, 2))
  32. a = d4.keys: crr(d4.Count + 1, 1) = "总计"
  33. For i = 0 To d4.Count - 1
  34.     crr(i + 1, 1) = a(i): s = 0
  35.     For j = 2 To UBound(brr, 2) - 1
  36.         zf = a(i) & "," & brr(1, j)
  37.         crr(i + 1, j) = d3(zf)
  38.         s = s + Val(crr(i + 1, j))
  39.         crr(UBound(crr), j) = crr(UBound(crr), j) + Val(crr(i + 1, j))
  40.     Next
  41.     crr(i + 1, UBound(brr, 2)) = s
  42.     s2 = s2 + s
  43. Next
  44. crr(UBound(crr), UBound(crr, 2)) = s2
  45. [j3].Resize(UBound(crr), UBound(crr, 2)) = crr
  46. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-6-13 21:29 | 显示全部楼层
dsmch 发表于 2015-6-8 07:03

怎么数据少时会出错？

正则排序2.rar

13.92 KB, 下载次数: 2

点评

dsmch
增加：On Error Resume Next  发表于 2015-6-14 15:58
回复

使用道具 举报

 楼主| 发表于 2015-6-14 06:56 | 显示全部楼层
dsmch 发表于 2015-6-8 07:03

问题一：On Error Resume Next '将此句注释去掉会出错？？？？？？？？？？？？？？？？？

问题二：纯文本不能排在前面，不能排序了。

正则排序TranForm加个总计实现数据透视.rar

13.27 KB, 下载次数: 2

点评

dsmch
什么是纯文本？0a不是  发表于 2015-6-14 15:59
回复

使用道具 举报

 楼主| 发表于 2015-6-14 10:05 | 显示全部楼层
dsmch 发表于 2015-6-8 07:03

特别工序 怎么排在最后了？

正则排序TranForm加个总计实现数据透视.rar

13.36 KB, 下载次数: 2

点评

dsmch
0a改为纯文本试试  发表于 2015-6-14 16:00
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 11:03 , Processed in 0.429329 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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