统计数字个数,请高师赐教,谢谢

徐海洋

3.rar (18.11 KB, 下载次数: 12)

2025-11-3 14:23 上传

点击文件名下载附件

liulang0808

liulang0808

如果对应的区域有调整，需要根据实际情况调整代码

徐海洋

liulang0808 发表于 2025-11-3 14:37
如果对应的区域有调整，需要根据实际情况调整代码

谢谢高师,怎么不一样,个数按从小到大排列

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    tm = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    arr = Me.[b3].CurrentRegion
    brr = Me.[i3].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            s = arr(i, j)
            If s <> Empty Then d(s) = d(s) + 1
        Next
    Next
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        For j = 1 To UBound(brr, 2)
            s = brr(i, j)
            If s <> Empty Then dic(s) = dic(s) + 1
        Next
    Next
    Me.[s3].Resize(1000, 4).ClearContents
    Me.[s3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    Me.[u3].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - tm, "0.0000") & " 秒！！！", 64
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()  '//2025.11.3
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     [s3:v1000].ClearContents
   
5.     arr = Range("b2").CurrentRegion.Offset(1).Value
   
6.     For Each k In arr
   
7.         If Len(k & "") Then d(k) = d(k) + 1
   
8.     Next
   
9.     Set Rng = [s3].Resize(d.Count, 2)
   
10.     Rng.Value = Application.Transpose(Array(d.keys, d.items))
    
11.     Rng.Sort Key1:=Rng.Columns(2), Order1:=1, Key2:=Rng.Columns(1), Order2:=1, Header:=xlNo
    
12.     d.RemoveAll
    
13.     arr = Range("i2").CurrentRegion.Offset(1).Value
    
14.     For Each k In arr
    
15.         If Len(k & "") Then d(k) = d(k) + 1
    
16.     Next
    
17.     Set Rng = [u3].Resize(d.Count, 2)
    
18.     Rng.Value = Application.Transpose(Array(d.keys, d.items))
    
19.     Rng.Sort Key1:=Rng.Columns(2), Order1:=1, Key2:=Rng.Columns(1), Order2:=1, Header:=xlNo
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "OK！"
    
22. End Sub
    
23. 
    

复制代码

ylj518

公式很简单啊！

quqiyuan

排个序吧