大小值的查找提取！

zhouxingyu

上贴的题经过几位老师的提示发现很不严谨，重新修改。烦请老师再予解答，多谢了！
大与小.rar (15.64 KB, 下载次数: 29)

2024-12-11 15:11 上传

点击文件名下载附件

xlj310

1. Sub 测试()
   
2.     ReDim 大结果(1 To 10000, 1 To 5)
   
3.     ReDim 小结果(1 To 10000, 1 To 5)
   
4.     With ThisWorkbook
   
5.         For Each 工作表 In .Worksheets
   
6.             With 工作表
   
7.                 Select Case .Name
   
8.                     Case "max", "min" '什么也不做
   
9.                     Case Else
   
10.                         原始数据 = .[A1].CurrentRegion
    
11.                         最行 = UBound(原始数据)
    
12.                         C列 = Application.WorksheetFunction.Index(原始数据, 0, 3)
    
13.                         最大值 = Application.Max(C列)
    
14.                         最小值 = Application.Min(C列)
    
15.                         For 行 = 1 To 最行
    
16.                             If 原始数据(行, 3) = 最大值 Then
    
17.                                 大计数 = 大计数 + 1
    
18.                                 For 列 = 1 To 5
    
19.                                     大结果(大计数, 列) = 原始数据(行, 列)
    
20.                                 Next
    
21.                             End If
    
22.                             If 原始数据(行, 3) = 最小值 Then
    
23.                                 小计数 = 小计数 + 1
    
24.                                 For 列 = 1 To 5
    
25.                                     小结果(小计数, 列) = 原始数据(行, 列)
    
26.                                 Next
    
27.                             End If
    
28.                         Next
    
29.                 End Select
    
30.             End With
    
31.         Next
    
32.         .Worksheets("max").[A2].Resize(大计数, 5).Value = 大结果
    
33.         .Worksheets("min").[A2].Resize(小计数, 5).Value = 小结果
    
34.     End With
    
35. End Sub

复制代码

z865593849

遍历表找最值

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To 1000, 1 To 5)
   
6. ReDim crr(1 To 1000, 1 To 5)
   
7. For Each sht In Sheets
   
8.     If InStr("max,min", sht.Name) = 0 Then
   
9.     arr = sht.Range("a1").CurrentRegion.Value
   
10.         For i = 1 To UBound(arr)
    
11.             s = arr(i, 2)
    
12.             If Not dic.exists(s) Then
    
13.                 m = m + 1: n = n + 1
    
14.                 dic(s) = m
    
15.                 For c = 1 To 5
    
16.                     brr(m, c) = arr(i, c)
    
17.                     crr(m, c) = arr(i, c)
    
18.                 Next
    
19.             Else
    
20.                 r = dic(s)
    
21.                 If arr(i, 3) > brr(r, 3) Then
    
22.                     For c = 1 To 5
    
23.                         brr(r, c) = arr(i, c)
    
24.                     Next
    
25.                 ElseIf arr(i, 3) < crr(r, 3) Then
    
26.                     For c = 1 To 5
    
27.                        crr(r, c) = arr(i, c)
    
28.                     Next
    
29.                 End If
    
30.             End If
    
31.                
    
32.         Next
    
33. 
    
34.     End If
    
35. Next
    
36. Sheet1.Range("a2").Resize(m, 5) = brr
    
37. Sheet8.Range("a2").Resize(m, 5) = crr
    
38. Set dic = Nothing
    
39. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.11
   
2.     ReDim brr(1 To 10000, 1 To 5)
   
3.     ReDim crr(1 To 10000, 1 To 5)
   
4.     For Each sht In Sheets
   
5.         If InStr("max|min", sht.Name) = 0 Then
   
6.             With sht
   
7.                 R = .Cells(Rows.Count, 1).End(3).Row
   
8.                 arr = .[a1].Resize(R, 5)
   
9.                 Max = Application.Max(.[c2].Resize(R - 1))
   
10.                 Min = Application.Min(.[c2].Resize(R - 1))
    
11.                 For i = 1 To UBound(arr)
    
12.                     If arr(i, 3) = Max Then
    
13.                         m = m + 1
    
14.                         For j = 1 To UBound(arr, 2)
    
15.                             brr(m, j) = arr(i, j)
    
16.                         Next
    
17.                     End If
    
18.                     If arr(i, 3) = Min Then
    
19.                         n = n + 1
    
20.                         For j = 1 To UBound(arr, 2)
    
21.                             crr(n, j) = arr(i, j)
    
22.                         Next
    
23.                     End If
    
24.                 Next
    
25.             End With
    
26.         End If
    
27.     Next
    
28.     With Sheets("max")
    
29.         .UsedRange.Offset(1).ClearContents
    
30.         .[a2].Resize(m, 5) = brr
    
31.     End With
    
32.     With Sheets("min")
    
33.         .UsedRange.Offset(1).ClearContents
    
34.         .[a2].Resize(n, 5) = crr
    
35.     End With
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

zhouxingyu

z865593849 发表于 2024-12-11 15:48
遍历表找最值

非常感谢，今天分加完了，明天补上。

zhouxingyu

ykcbf1100 发表于 2024-12-11 16:05
附件供参考。。。

非常感谢老师再次出手相助。今天没分了，明天补加分。

Qs18

试试..........

Qs18

试试.........