分类多条件提取问题，较难，请大神帮助

候鸟之细雨言寺

多类别变化，提取问题，较难，请大神帮助，谢谢。按不同的班设置的前N名的区间，如30——42，即提取这个班的前30名到前42名的数据。

cnmlgb9998

你这表有问题啊！ 你每个班别按要求选 N 个，但是，你的那个标准值 只给了一个。是要把 选出的N个实际值 与这个一标准值做减法？？？？？

abc123281

看“提取结果”表，共有16个班，需要每个班的前10名，不知这样理解对不对？

LIUZHU

这个问题最难的地方，是猜作者的意图很难。

候鸟之细雨言寺

abc123281 发表于 2024-3-21 21:58
看“提取结果”表，共有16个班，需要每个班的前10名，不知这样理解对不对？

不是，是指定的前N名的区间，如30——42，即这个班的前30名到前42名的数据。

候鸟之细雨言寺

cnmlgb9998 发表于 2024-3-21 21:08
你这表有问题啊！ 你每个班别按要求选 N 个，但是，你的那个标准值 只给了一个。是要把 选出的N个实际值 与 ...

是指定的前N名的区间，如30——42，即这个班的前30名到前42名的数据。

候鸟之细雨言寺

LIUZHU 发表于 2024-3-21 22:13
这个问题最难的地方，是猜作者的意图很难。

是指定的前N名的区间，如30——42，即这个班的前30名到前42名的数据。

fzxba

1. Sub test1()
   
2.   
   
3.   Dim ar, br, cr(1 To 100, 1 To 80), dict(1) As Object
   
4.   Dim setup, data, results, target As Range
   
5.   Dim i As Long, j As Long, x As Long, y As Long
   
6.   Dim pos As Long, col As Long, posRow As Long, rowSize As Long, colSize As Long
   
7.   
   
8.   Sheet3.Activate
   
9.   Cells.Clear
   
10.   
    
11.   Application.ScreenUpdating = False
    
12.   
    
13.   For j = LBound(dict) To UBound(dict)
    
14.     Set dict(j) = CreateObject("Scripting.Dictionary")
    
15.   Next
    
16.   
    
17.   Set target = Range("A2")
    
18.   
    
19.   ar = Split("分数 排名 划线分 差值")
    
20.   For i = 4 To UBound(cr)
    
21.     cr(i, 1) = i - 3
    
22.   Next
    
23.   cr(1, 1) = "班别"
    
24.   cr(3, 1) = "排序"
    
25.   colSize = 2
    
26.   
    
27.   setup = Sheet1.Range("A1").CurrentRegion.Value
    
28.   For i = 3 To UBound(setup)
    
29.     dict(0).Add setup(i, 1), i ' Array(i, Split(setup(i, 2), "—"))
    
30.   Next
    
31.   For j = 3 To UBound(setup, 2)
    
32.     dict(0).Add setup(2, j), j
    
33.     cr(2, colSize) = setup(2, j)
    
34.     dict(1).Add cr(2, colSize), colSize
    
35.     For i = 0 To UBound(ar)
    
36.       cr(3, colSize + i) = ar(i)
    
37.     Next
    
38.     colSize = colSize + 4
    
39.   Next
    
40.   colSize = colSize - 1
    
41.   
    
42.   With Sheet2
    
43.     data = .Range("A1", .Range("A1").CurrentRegion.Offset(1)).Value
    
44.   End With
    
45.   QuickSort data, 2, UBound(data) - 1, 1, UBound(data, 2), 2, False '班级名为 数字 形式
    
46.   
    
47.   pos = 1
    
48.   For i = 2 To UBound(data) - 1
    
49.     If data(i, 2) <> data(i + 1, 2) Then
    
50.       rowSize = 3
    
51.       results = cr
    
52.       results(1, 2) = data(i, 2)
    
53.       posRow = dict(0)(data(pos + 1, 2))
    
54.       br = Split(setup(posRow, 2), "—")
    
55.       For x = 3 To UBound(setup, 2)
    
56.         col = dict(1)(setup(2, x))
    
57.         For y = 1 To br(1) - br(0) + 1
    
58.           results(y + rowSize, col + 2) = setup(posRow, x)
    
59.         Next
    
60.       Next
    
61.       QuickSort data, pos + 1, i, 1, UBound(data, 2), UBound(data, 2) - 1, True
    
62.       For y = pos + br(0) To pos + br(1)
    
63.         rowSize = rowSize + 1
    
64.         For x = 6 To UBound(data, 2) Step 2
    
65.           col = dict(1)(data(1, x))
    
66.           results(rowSize, col) = data(y, x)
    
67.           results(rowSize, col + 1) = data(y, x + 1)
    
68.           If results(rowSize, col) Then results(rowSize, col + 3) = results(rowSize, col) - results(rowSize, col + 2)
    
69.         Next
    
70.         If data(y, 2) <> data(y + 1, 2) Then Exit For
    
71.       Next
    
72.       With target
    
73.         .Resize(rowSize, colSize).Value = results
    
74.         With .CurrentRegion
    
75.           Intersect(.Offset(0), .Offset(1)).Borders.LineStyle = xlContinuous
    
76.           .HorizontalAlignment = xlCenter
    
77.           .Font.Name = "宋体"
    
78.           .Rows("1:3").Font.Bold = True
    
79.         End With
    
80.         For j = 2 To colSize Step 4
    
81.           .Offset(1, j - 1).Resize(, UBound(ar) + 1).HorizontalAlignment = xlCenterAcrossSelection
    
82.         Next
    
83.       End With
    
84.       Set target = Cells(Rows.Count, 1).End(xlUp).Offset(2)
    
85.       pos = i
    
86.     End If
    
87.   Next
    
88.   
    
89.   Set target = Nothing
    
90.   For j = LBound(dict) To UBound(dict)
    
91.     Set dict(j) = Nothing
    
92.   Next
    
93.   
    
94.   Application.ScreenUpdating = True
    
95.   Beep
    
96. End Sub
    
97. 
    
98. Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pCol As Long, Optional Flag As Boolean = True)
    
99.   Dim t As Long, b As Long, j As Long, x As Long, pivot, swap
    
100.   t = u
     
101.   b = d
     
102.   pivot = ar((u + d) \ 2, pCol)
     
103.   While t <= b
     
104.     If Flag Then        'Order by number DESC
     
105.       Do While t < d
     
106.         If ar(t, pCol) > pivot Then t = t + 1 Else Exit Do
     
107.       Loop
     
108.       Do While b > u
     
109.         If ar(b, pCol) < pivot Then b = b - 1 Else Exit Do
     
110.       Loop
     
111.     Else                'Order by number ASC
     
112.       Do While t < d
     
113.         If ar(t, pCol) < pivot Then t = t + 1 Else Exit Do
     
114.       Loop
     
115.       Do While b > u
     
116.         If ar(b, pCol) > pivot Then b = b - 1 Else Exit Do
     
117.       Loop
     
118.     End If
     
119.     If t < b Then
     
120.       For x = l To r
     
121.         swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
     
122.       Next
     
123.       t = t + 1: b = b - 1
     
124.     Else
     
125.       If t = b Then t = t + 1: b = b - 1
     
126.     End If
     
127.   Wend
     
128.   If t < d Then QuickSort ar, t, d, l, r, pCol, Flag
     
129.   If b > u Then QuickSort ar, u, b, l, r, pCol, Flag
     
130. End Function

复制代码

fzxba

求助提取信息.zip (152.04 KB, 下载次数: 15)

2024-3-23 15:28 上传

点击文件名下载附件

候鸟之细雨言寺

fzxba 发表于 2024-3-23 15:28

感谢您的帮助，谢谢。