感谢版主liulang0808、EH侠圣zpy2、EH铁杆gwjkkkkk、EH能手鄂龙蒙等，问题圆满解决！

xx18

各位大侠，小女子求教“频次排名”的函数或VBA问题，请各位大侠帮助！
问题如下：
　　工厂有成千上万的工人，每天都有工作积极的员工，虽然每月有30天左右，每年有365天，为方便说明问题，我们暂且模拟一个工厂8天的工作记录，工厂每天三班倒上班，工人每一天都可以选择工作一班、两班、甚至三班，每班都按照工作积极的积极成果都会被记录在案，在基本工资之外，月底按照记录次数给予绩效奖励，虽然我们模拟的是8天，其实每月都会统计30天左右，每年统计360天左右，年排前几名会得到年终奖。
　　所以，如果一个工人一天上2个班，且2个班工作都积极，则会在一天内被记录2次，甚至一天被记录3次，每个人姓名之间有不固定数量的空格或字符隔开。
　　如上所示是这个工厂8天的工作记录，请运用函数公式或VBA把8天记录中的人员名单按照各自被记录的总次数排序，存放到“排名”工作表中（模拟效果）。
　　“绩效记录”工作表是原始数据，其中A列为日期，B列为人员名单
　　“排名”工作表是统计结果，其中A列是被记录的工人名单，B列中是该工人被记录的总次数。
　　谢谢！
附件：频次排名
频次排名.rar (9.85 KB, 下载次数: 13)

2022-12-4 17:20 上传

点击文件名下载附件

附图：频次排名原始数据

附图：频次排名模拟结果

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange
    With CreateObject("vbscript.regexp")
        .Pattern = "[一-龥]+"
        .Global = True
        For j = 2 To UBound(arr)
            For Each m In .Execute(arr(j, 2))
                d(m.Value) = d(m.Value) + 1
            Next m
        Next j
    End With
    Sheets(1).[c1:d1].Value = Array("姓名", "次数")
    Sheets(1).[c2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    Sheets(1).[d2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End Sub

liulang0808

顺序楼主可以自己排，模拟了一个提取，供参考

jiangxiaoyun

gwjkkkkk

Sub TEST()
    Dim arr, brr, i&, j&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    arr = [A1].CurrentRegion
    For i = 2 To UBound(arr)
      brr = strExMatch(arr(i, 2))
      If Join(brr) <> "" Then
        For j = 1 To UBound(brr)
           dic(brr(j)) = dic(brr(j)) + 1
        Next j
      End If
    Next i
    arr = Application.Transpose(Array(dic.keys, dic.items))
    bsort arr, 1, UBound(arr), 1, UBound(arr, 2), 2, False
    With Sheets(2)
       .[A1].CurrentRegion.Offset(1).Clear
       .[A2].Resize(UBound(arr), 2) = arr
       .Activate
    End With
    Beep
End Sub
Function strExMatch(ByVal strTxt As String) As Variant
    Dim regEx As Object, ar(), R&, aMatch, Matches
    Set regEx = CreateObject("Vbscript.RegExp")
      With regEx
        .Global = True
        .Pattern = "[\u4e00-\u9fa5]{2,4}"
      End With
      Set Matches = regEx.Execute(strTxt)
      For Each aMatch In Matches
        R = R + 1
        ReDim Preserve ar(1 To R)
        ar(R) = aMatch
      Next
      strExMatch = ar
End Function
Function bsort(arr, first, last, left, right, key, order)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) <> arr(j + 1, key) Then
        If arr(j, key) < arr(j + 1, key) Xor order Then
          For k = left To right
            t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
          Next
        End If
      End If
  Next j, i
End Function

gwjkkkkk

参与一下。。。

鄂龙蒙

频次排名.rar (25.92 KB, 下载次数: 9)

2022-12-4 19:07 上传

点击文件名下载附件

zpy2

select * from 正则表达式拆分行之绩效记录按频次排名 limit 3;
cli_split_data~正则表达式拆分行之绩效记录按频次排名~[^\p{Han}]+~绩效记录;
create temp table aa as
select 绩效记录 姓名,count(*) 次数 from 正则表达式拆分行之绩效记录按频次排名split group by 绩效记录;
select * from aa order by 次数 desc;

xx18

liulang0808 发表于 2022-12-4 17:51
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange

小女子感谢版主liulang0808大人的指教！多谢了！

xx18

gwjkkkkk 发表于 2022-12-4 18:12
Sub TEST()
    Dim arr, brr, i&, j&, dic As Object
    Set dic = CreateObject("Scripting.Dictionar ...

小女子感谢gwjkkkkk大人的悉心教导！