大小值的查找提取！

ykcbf1100

小改一下。。。

1. Sub ykcbf()   '//2024.12.13
   
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 = .UsedRange.Find("*", , -4163, , 1, 2).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
    
38. 
    

复制代码

zhouxingyu

ykcbf1100 发表于 2024-12-13 14:07
改一下。。。

非常完美，非常感谢！！！

zhouxingyu

ykcbf1100 发表于 2024-12-13 14:08
小改一下。。。

老师，如果查找的列是在D列，在哪改一下？
弄明白了，If arr(i, 3) =  列取决于这里的值

zhouxingyu

ykcbf1100 发表于 2024-12-13 14:08
小改一下。。。

老师如果查找的列是在D列，在哪改一下？
明白了
If arr(i, 3)  是C列
If arr(i, 4)  就是D列，以此类推

ykcbf1100

zhouxingyu 发表于 2024-12-13 14:37
老师如果查找的列是在D列，在哪改一下？

我改成通用版吧，这里改一下就行了。

col = 3   '//查找的列号

ykcbf1100

再改一下，通用性好一点。

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

复制代码

zhouxingyu

ykcbf1100 发表于 2024-12-13 15:15
我改成通用版吧，这里改一下就行了。

col = 3   '//查找的列号

彻底完美了，非常感谢！！！

ynzsvt

zhouxingyu 发表于 2024-12-13 13:29
谢谢，请教行范围超出10行怎么改？

没行数限制呀，只是根据A列有值确定C列有效。

ykcbf1100

ynzsvt 发表于 2024-12-13 17:33
没行数限制呀，只是根据A列有值确定C列有效。

最大行号在C列。

chxw68

练练手吧。