Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2133|回复: 4

[已解决]组合出现次数多到少排序出来

[复制链接]
发表于 2016-3-22 22:47 | 显示全部楼层 |阅读模式
本帖最后由 雨夜1987 于 2016-3-23 15:59 编辑

如图
最佳答案
2016-3-23 13:52
  1. Sub tt()
  2.     arr = Range("a1:a" & [a65536].End(3).Row)
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 1)
  6.         xrr = Split(x, " ")
  7.         For k = 0 To UBound(xrr)
  8.             d(xrr(k)) = d(xrr(k)) + 1
  9.         Next
  10.         dk = d.keys
  11.         For m = 0 To UBound(dk) - 1
  12.             For n = m + 1 To UBound(dk)
  13.                 If d(dk(m)) < d(dk(n)) Then
  14.                     tmp = dk(m): dk(m) = dk(n): dk(n) = tmp
  15.                 End If
  16.             Next
  17.         Next
  18.         arr(i, 1) = Join(dk, " ")
  19.     Next
  20.     arr(1, 1) = "变动后"
  21.     [b1].Resize(UBound(arr)) = arr
  22. End Sub
复制代码
3.png

新建 Microsoft Excel 工作表.zip

1.96 KB, 下载次数: 7

发表于 2016-3-23 13:43 | 显示全部楼层
本帖最后由 just2seeusmile 于 2016-3-23 13:47 编辑
  1. Sub order()
  2.     Dim t$, a, b, i%, j%, n%, d, x$
  3.     t = Sheets(1).Range("A2").Value
  4.     a = Split(t, " ")
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     For i = 0 To UBound(a)
  7.         If d.Exists(a(i)) = 0 Then
  8.             n = 0
  9.             For j = 0 To UBound(a)
  10.                 If a(j) = a(i) Then
  11.                     n = n + 1
  12.                 End If
  13.             Next j
  14.             d(a(i)) = n
  15.         End If
  16.     Next i
  17.     b = Application.Transpose(Array(d.keys, d.items))
  18.     For i = 1 To UBound(b, 1) - 1
  19.         For j = i + 1 To UBound(b, 1)
  20.             If b(j, 2) > b(i, 2) Then
  21.                 temp1 = b(j, 1): temp2 = b(j, 2)
  22.                 b(j, 1) = b(i, 1): b(j, 2) = b(i, 2)
  23.                 b(i, 1) = temp1: b(i, 2) = temp2
  24.             End If
  25.         Next j
  26.     Next i
  27.     x = b(1, 1)
  28.     For i = 2 To UBound(b, 1)
  29.         x = x + " " + b(i, 1)
  30.     Next i
  31.     Sheets(1).Range("B2").Value = x
  32. End Sub
复制代码
回复

使用道具 举报

发表于 2016-3-23 13:52 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     arr = Range("a1:a" & [a65536].End(3).Row)
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 1)
  6.         xrr = Split(x, " ")
  7.         For k = 0 To UBound(xrr)
  8.             d(xrr(k)) = d(xrr(k)) + 1
  9.         Next
  10.         dk = d.keys
  11.         For m = 0 To UBound(dk) - 1
  12.             For n = m + 1 To UBound(dk)
  13.                 If d(dk(m)) < d(dk(n)) Then
  14.                     tmp = dk(m): dk(m) = dk(n): dk(n) = tmp
  15.                 End If
  16.             Next
  17.         Next
  18.         arr(i, 1) = Join(dk, " ")
  19.     Next
  20.     arr(1, 1) = "变动后"
  21.     [b1].Resize(UBound(arr)) = arr
  22. End Sub
复制代码

新建 Microsoft Excel 工作表.rar

10.07 KB, 下载次数: 17

回复

使用道具 举报

发表于 2016-3-23 14:04 | 显示全部楼层
或者这样。
  1. Sub tt()
  2.     arr = Range("a1:a" & [a65536].End(3).Row)
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 1)
  6.         xrr = Split(x, " ")
  7.         For k = 0 To UBound(xrr)
  8.             d(xrr(k)) = d(xrr(k)) + 1
  9.         Next
  10.         ReDim crr(1 To Application.Max(d.items))
  11.         For Each x In d.keys
  12.             crr(d(x)) = crr(d(x)) & " " & x
  13.         Next
  14.         For k = UBound(crr) To 1 Step -1
  15.             If Len(crr(k)) > 0 Then y = y & " " & Trim(crr(k))
  16.         Next
  17.         arr(i, 1) = Trim(y)
  18.     Next
  19.     arr(1, 1) = "变动后"
  20.     [b1].Resize(UBound(arr)) = arr
  21. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-3-23 15:58 | 显示全部楼层
grf1973 发表于 2016-3-23 13:52

谢谢,棒棒哒
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 17:50 , Processed in 0.513451 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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