想要用VBA实现这种排序结果是否可以，谢谢！

feixiangye

chxw68 发表于 2023-10-20 09:43
参与一下。

谢谢，我好好研究一下代码，鲜花明天补上

feixiangye

liulang0808 发表于 2023-10-19 20:05
Sub test()
    Set da = CreateObject("Scripting.Dictionary")
    Set dd = CreateObject("Scripting. ...

谢谢，鲜花今天没有了，明天补上

一招秒杀

增加两个辅助列，剩下的用Ado一句搞定，这质量如何 ？

笨鸟飞不高

Sub AwTest2()
    Dim i&, j%, k%, r&, z&, y&, m%, x&, Mc$, kSr
    Dim Arr, Brr, Crr, kAr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Arr = Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        Mc = Arr(i, 1)
        If Not d.Exists(Mc) Then Set d(Mc) = CreateObject("Scripting.Dictionary")
        d(Mc)(1 & " " & i) = ""
    Next
    Brr = Range("D1").CurrentRegion
    For i = 2 To UBound(Brr)
        Mc = Brr(i, 1)
        If Not d.Exists(Mc) Then Set d(Mc) = CreateObject("Scripting.Dictionary")
        d(Mc)(2 & " " & i) = ""
    Next
    ReDim Crr(1 To UBound(Arr) + UBound(Brr), 1 To 5)
    For Each kSr In d
        kAr = d(kSr).Keys
        z = 0: y = 0 '对应每个关键字左、右输出的计数序号
        For k = 0 To UBound(kAr)
            m = Split(kAr(k))(0)
            x = Split(kAr(k))(1)
            If m = 1 Then '输出数组Arr的数据
                z = z + 1
                For j = 1 To UBound(Arr, 2)
                    Crr(r + z, j) = Arr(x, j)
                Next
            Else  '输出数组Brr的数据
                y = y + 1
                For j = 1 To UBound(Brr, 2)
                    Crr(r + y, j + 3) = Brr(x, j)
                Next
            End If
        Next
        r = r + Application.Max(z, y)
    Next
    Range("T2").Resize(r, 5) = Crr
End Sub

练习一个字典嵌套写法！