多列排序、多列数据相同的行对齐，否则插入空行

tender888

tender888 发表于 2022-12-21 14:33
我是小白一个，工作中需要用到的时候才现学现买。怎么送花啊，真的好想感谢这些给我帮助的大师 ...

知道在哪送花了

tender888

笨鸟飞不高 发表于 2022-12-21 12:47
当前附件，凑一个！

大师有空麻烦帮忙解释一下或者说下思路，我看了两天还是看不明白思路

Sub AwTest()
    Dim i&, j%, c%, x&, r&, m&, h&, lSr$, Sr$, eRow&, arr, kAr, Ar, Br, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    lSr = "一,1,二,2,三,3"
    With Sheets("Temp")
        eRow = Application.Max(.Cells(Rows.Count, "D").End(3).Row, _
                    .Cells(Rows.Count, "I").End(3).Row)
        arr = .Range("A2:I" & eRow)
        ReDim tAr(1 To UBound(arr) * 2, 1 To 5)
        For i = 1 To UBound(arr)
            For j = 1 To UBound(arr, 2) Step 5
                If j = 1 Then c = 4 Else c = 5
                If Len(arr(i, j)) Then
                    Sr = arr(i, j) & "|" & arr(i, j + 1) & "|" & arr(i, j + 2)
                    x = d(Sr)
                    If x = 0 Then
                        r = r + 1: x = r: d(Sr) = x
                        tAr(x, 1) = Val(Mid(lSr, InStr(lSr, Split(arr(i, j), "类")(0)) + 2, 1))
                        tAr(x, 2) = Val(Split(arr(i, j + 1), "类")(0))
                        tAr(x, 3) = Val(Split(arr(i, j + 2), "名称")(1))
                    End If
                    tAr(x, c) = IIf(tAr(x, c) = "", i, tAr(x, c) & "|" & i)
                End If
            Next
        Next
        
        kAr = Array(1, 1, 2, 1, 3, 1)
        bSort tAr, 1, r, 1, 5, kAr
        
        ReDim brr(1 To UBound(arr) * 2, 1 To UBound(arr, 2))
        x = 0
        For i = 1 To r
            Ar = Split(tAr(i, 4), "|"): Br = Split(tAr(i, 5), "|")
            m = Application.Max(UBound(Ar), UBound(Br))
            For h = 0 To m
                x = x + 1
                If h <= UBound(Ar) Then
                    For j = 1 To 4
                        brr(x, j) = arr(Val(Ar(h)), j)
                    Next
                End If
                If h <= UBound(Br) Then
                    For j = 6 To 9
                        brr(x, j) = arr(Val(Br(h)), j)
                    Next
                End If
            Next
        Next
        .Range("U2").Resize(x, UBound(brr, 2)) = brr
    End With
End Sub

Sub bSort(arr, TLine, BLine, LLine, RLine, kAr)
    Dim i&, j&, u%, m%, o%, k%, tt
    u = UBound(kAr) - 1
    For m = u To 0 Step -2
        o = kAr(m + 1)
        For i = BLine To TLine + 1 Step -1
            For j = TLine To i - 1
                If o = 1 Then
                    If arr(j, kAr(m)) > arr(j + 1, kAr(m)) Then
                        For k = LLine To RLine
                            tt = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = tt
                        Next
                    End If
                Else
                    If arr(j, kAr(m)) < arr(j + 1, kAr(m)) Then
                        For k = LLine To RLine
                            tt = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = tt
                        Next
                    End If
                End If
            Next
        Next
    Next
End Sub