求指定数据按出现次数升序排序的vba

CAONI

1、b5开始的b列各单元格中分别填有数字，每2个数字间隔一个空格；
2、以行为单位，每隔2行为一小组，即b5-b6，b7-b8，b9-b10各为一组...将各组数字中4 5 9这3个数按出现次数多少按升序排序在d5开始的d列， 即：b5-b6排序在d5，b7-b8排序在d6，b9-b10排序在d7...每个单元格一个数据
3、4 5 9这3个数据如在b列中没有则以0次计算，相同次数的数据按从小到大排序，4 5 9这3个数据必须出现在结果中。
谢谢!!!

按次排序459.rar (11.39 KB, 下载次数: 7)

2021-1-10 19:52 上传

点击文件名下载附件

liulang0808

for 循环遍历+字典计数
排序部分看看表格自带功能是否能满足

CAONI

liulang0808 发表于 2021-1-11 07:26
for 循环遍历+字典计数
排序部分看看表格自带功能是否能满足

版主你好，本题我要解决的关键问题是：怎样将4、5、9这3个不是连续的数据输入到字典，如果是4到9就一个循环解决，后面的for 循环遍历+字典计数这部分好写。

loirol

CAONI 发表于 2021-1-11 08:54
版主你好，本题我要解决的关键问题是：怎样将4、5、9这3个不是连续的数据输入到字典，如果是4到9就一个循 ...

定义变量i,j，数组arr

1. arr= [b5].currentregion
   
2. for i  = 1 to ubound(arr)
   
3.     for j = 1 to len((arr(i,1)))
   
4.         d(Val(Mid(arr(i, 1), j, 1))) = d(Val(Mid(arr(i, 1), j, 1))) + 1
   
5.     next
   
6. next

复制代码

加字典就用这个方法吧

yjh_27

CAONI 发表于 2021-1-11 08:54
版主你好，本题我要解决的关键问题是：怎样将4、5、9这3个不是连续的数据输入到字典，如果是4到9就一个循 ...

自定义函数

CAONI

yjh_27 发表于 2021-1-11 10:02
自定义函数

老师你好，程序经测试在0-9这10个数据中按次数排序完全符合要求，请将程序扩展到求其他任意位数，例如求：5、11、77、88、189这5个数按次数升序排序，谢谢！！！

yjh_27

CAONI 发表于 2021-1-11 10:55
老师你好，程序经测试在0-9这10个数据中按次数排序完全符合要求，请将程序扩展到求其他任意位数，例如求 ...

参见附件。

liulang0808

CAONI 发表于 2021-1-11 08:54
版主你好，本题我要解决的关键问题是：怎样将4、5、9这3个不是连续的数据输入到字典，如果是4到9就一个循 ...

arr=array(4,5,9)
这样就可以调用了

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, dic(1), t, m, n, key, flag As Boolean
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Split("4,5,9", ",")
  For i = 0 To UBound(arr)
    dic(0)(arr(i)) = 1
  Next
  arr = Range("b5:b" & [b5].End(xlDown).Row).Value
  If UBound(arr, 1) Mod 2 > 0 Then MsgBox "!": Exit Sub
  ReDim brr(1 To UBound(arr, 1) / 2, 1 To dic(0).Count)
  For i = 1 To UBound(arr, 1) Step 2
    For j = i To i + 1
      t = Split(arr(j, 1))
      For k = 0 To UBound(t)
        If dic(0).exists(t(k)) Then dic(1)(t(k)) = dic(1)(t(k)) + 1
      Next
    Next
    ReDim crr(1 To 2, 1 To UBound(brr, 2)) As Long
    For Each key In dic(0).keys
      n = n + 1: crr(1, n) = key
      If dic(1).exists(key) Then crr(2, n) = dic(1)(key)
    Next
    For j = 1 To UBound(crr, 2) - 1
      For k = j + 1 To UBound(crr, 2)
        If crr(2, j) < crr(2, k) Then
          flag = True
        ElseIf crr(2, j) = crr(2, k) Then
          If crr(1, j) > crr(1, k) Then flag = True
        End If
        If flag Then
          t = crr(1, j): crr(1, j) = crr(1, k): crr(1, k) = t
          t = crr(2, j): crr(2, j) = crr(2, k): crr(2, k) = t
          flag = False
        End If
      Next
    Next
    m = m + 1
    For j = 1 To UBound(brr, 2)
      brr(m, j) = crr(1, j)
    Next
    dic(1).RemoveAll: n = 0
  Next
  [d5].Resize(m, UBound(brr, 2)) = brr
End Sub

CAONI

yjh_27 发表于 2021-1-11 11:40
参见附件。

老师你好，程序经测试满足要求，谢谢！！！我想用按钮调用函数：xtcipxu2，结果不对，麻烦修改一下，谢谢！！！
Sub 按钮1_Click()
a = 5
For i = 5 To 10 Step 2
Range("q" & a).Resize(1, 3) = xtcipxu2(Range("b" & i & ":b" & i + 1), 2, "4 5 9")
a = a + 1
Next
End Sub