求助代码 按相同个数的多少重新排序

三等菜鸟

求一段代码，按相同个数的多少重新排序


谢谢

ykcbf1100

附件供参考。。。

gwjkkkkk

参与一下。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         arr = .Range("m3").CurrentRegion
   
8.         For j = 1 To UBound(arr, 2)
   
9.             d(arr(1, j)) = Empty
   
10.         Next
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         arr = .Range("a1:e" & r)
    
13.         ReDim brr(1 To UBound(arr), 1 To 1)
    
14.         For i = 1 To UBound(arr)
    
15.             For j = 1 To UBound(arr, 2)
    
16.                 If d.exists(arr(i, j)) Then
    
17.                     brr(i, 1) = brr(i, 1) + 1
    
18.                 End If
    
19.             Next
    
20.         Next
    
21.         .Range("f1").Resize(UBound(brr), 1) = brr
    
22.         .Range("a1:f" & r).Sort key1:=.Cells(1, 6), order1:=xlDescending, Header:=xlNo
    
23.         .Columns(6).ClearContents
    
24.     End With
    
25. End Sub
    

复制代码

chxw68

参与一下。

三等菜鸟

感谢楼上老师们的帮助！
我只选用了ykcbf1100老师的代码，一次成功，其他的没试
特别要感谢ykcbf1100，一天之中帮我解决了2个问题，十分感动

崇高敬礼

chxw68

三等菜鸟 发表于 2023-4-13 09:10
感谢楼上老师们的帮助！
我只选用了ykcbf1100老师的代码，一次成功，其他的没试
特别要感谢ykcbf1100，一 ...

估计以后其他人不会轻易给你写代码了。