老师们好！VBA取重复数，能否最多的排最上面，最少的排最下面。谢谢各位老师！！

13602822168

老师们好！VBA取重复数，能否最多的排最上面，最少的排最下面。谢谢各位老师！！

于箱长

那不就是先计个数，然后再排个序吗？

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, m&, n&, r&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    r = Cells(Rows.Count, "BR").End(xlUp).Row
    ar = Range("BR13:CK" & r).Value
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ar, 2)
            If Len(ar(i, j)) Then dic(ar(i, j)) = dic(ar(i, j)) + 1
        Next j
    Next i
   
    ar = Application.Transpose(Array(dic.keys, dic.items))
    ReDim br(1 To UBound(ar), 1 To 2): ReDim cr(1 To UBound(ar), 0)
    For i = 1 To UBound(ar)
        If ar(i, 2) > 1 Then
            m = m + 1
            br(m, 1) = ar(i, 1)
            br(m, 2) = ar(i, 2)
        Else
            n = n + 1
            cr(n, 0) = ar(i, 1)
        End If
    Next i
   
    [CM12].CurrentRegion.Offset(1).Clear
    If m Then
        bSort br, 1, m, 1, 2, 2, False
        [CM13].Resize(m) = br
    End If
    If n Then [CN13].Resize(n) = cr
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
Function bSort(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k)
                        ar(j, k) = ar(j + 1, k)
                        ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

请参考。。。

13602822168

gwjkkkkk 发表于 2024-8-23 18:58
请参考。。。

强大！！！！！！！！！！！谢谢！！！