一堆数据中按照某些列名要求取部分行

zxsea_7426

在ykcbf1100代码基础上修改而来:

'//2024.8.19
'//https://club.excelhome.net/thread-1699773-1-1.html
Sub test_zxsea()
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("数据源")
        r = .Cells(Rows.Count, 1).End(3).Row
        arr = .[a1].Resize(r, 6)

    For i = 2 To UBound(arr)
        s = arr(i, 1)
        s1 = arr(i, 3)
        If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
        If Not d(s).exists(s1) Then Set d(s)(s1) = CreateObject("Scripting.Dictionary")
        n = d(s)(s1).Count + 1
        d(s)(s1)(n) = .Cells(i, 1).Resize(1, 6)
    Next
    End With
   
    With Sheets("期望")
        .UsedRange.Offset(1).ClearContents
        la_ro =2
        For Each k In d.KEYS
            For Each Key In d(k).KEYS
                m = d(k)(Key).Count
                For x = 1 To m
                    .Cells(la_ro + x - 1, 1).Resize(1, 6) = d(k)(Key)(x)
                Next x
                Set Rng = .Cells(la_ro, 1).Resize(n, 6)
                Rng.Sort Rng.Columns(5), 2
               
                If m > 10 Then    '大于10行显示前10,其余数据清除
                    .Cells(la_ro + 10, 1).Resize(m - 10, 6).ClearContents
                    la_ro = la_ro + 11
                Else
                    la_ro = la_ro + m + 1
                End If
            Next
        Next
    End With
    Set d = Nothing
    MsgBox "OK！"
End Sub

zxsea_7426

ykcbf1100

zxsea_7426 发表于 2024-8-19 08:19
你这没有按排序列取前10

我原表加了黄底色数据，左侧代码跑出来的结果，右侧手工排序结果

这个是的，是我考虑不周。

你这数据是重新摸拟过的吧，原数据是排序好的。
数据提取前先排序好应该就可以了吧。

ynzsvt

一种是你手工排序好了后再运行代码，比如10楼。
还一种不先排序下代码复杂。

ykcbf1100

chxw68 发表于 2024-8-19 08:08
你好像没有考虑数据按“等待天数”排序问题。

这个有考虑的，这一句就是：Rng.Sort Rng.Columns(5), 2
但是，我没有考虑到按排名前十去取值。
我再看一下。

zhangcheng6688

mark,mark!!