求助代码求助代码

1吧吧

求助代码  求助代码

醉眼看尘世

参见附件，这个简单

杨建营

字典应用，请楼主参考。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&, j&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(1).[B1].CurrentRegion.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
            End If
        Next j
    Next i
   
    ar = Application.Transpose(Array(dic.keys, dic.items))
    bSort ar, 1, UBound(ar), 1, UBound(ar, 2), 2, False
    [E1].Resize(UBound(ar), 2) = ar
   
    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

参与一下。。。

1吧吧

感谢老师们的解答