[已解决]求助: 選取指定範圍內的最大/最小相差值

monstrooilis

請教各位高手下面的問題:

附件中, E 欄的"change of rate" 是B 欄中每2個數的相差值, 例如E3=B3-B2, 我想選取並在另外2 欄裡列出每5 行的最大與最小的相差值, 也就是列出 E2:E6 的最大/最小相差值, 然後到 E7:E11,... 如此類推直到最後5行。如果最後一組不夠5 行數, 也照樣選取。中間有些數值是空白的, 比如說5個數裡面有2個空白, 就只選取剩下3個數中的最大/最小相差值。

以首三組為例, 希望列出的結果為: E2:E6 最大相差是0.33, 最小是0。 E7:E11 最大相差是0.53, 最小差是0.03, 而E12:E16的最大相差為0.67, 最小的差數則是 -0.02 , 如此類推

請問可以如何以VBA 實現呢? 非常感謝指教!


maxmin.rar (30.35 KB, 下载次数: 26)

2011-9-21 22:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

mxg825

2011-9-22 12:37

这次应该达到你的要求了

1. Sub max2()
   
2. Dim MyMax!, MyMin!
   
3. Dim UpBool As Boolean
   
4. Dim Arr(), Crr()
   
5. Sheet1.Activate
   
6. Arr = Range("e2", [e65536].End(3).Offset(5))
   
7. ReDim Crr(1 To UBound(Arr), 1 To 2)
   
8. For i = 1 To UBound(Arr) - 5 Step 5
   
9.     For K = i To i + 4
   
10.        If IsNumeric(Arr(K, 1)) Then
    
11.             If UpBool Then
    
12.                  If Application.Max(Abs(MyMax), Abs(Arr(K, 1))) = Abs(Arr(K, 1)) Then
    
13.                      MyMax = Arr(K, 1)
    
14.                  ElseIf Application.Min(Abs(MyMin), Abs(Arr(K, 1))) = Abs(Arr(K, 1)) Then
    
15.                      MyMin = Arr(K, 1)
    
16.                  Else
    
17.                  End If
    
18.             Else
    
19.                  MyMax = Arr(K, 1)
    
20.                  MyMin = Arr(K, 1)
    
21.                  UpBool = True
    
22.             End If
    
23.        End If
    
24.     Next
    
25.     Crr(i, 1) = MyMax
    
26.     Crr(i, 2) = MyMin
    
27.     UpBool = False
    
28. Next
    
29. [f1].Resize(1, 2) = Array("max", "min")
    
30. [f2].Resize(UBound(Arr), 2) = Crr
    
31. End Sub

复制代码

跳转到最佳答案楼层

liuguansky

不明白前两组为什么不算负数，第三组又算。

liuguansky

哦了，以绝对值为准

monstrooilis

liuguansky 发表于 2011-9-21 23:18
哦了，以绝对值为准

對的, 列出的時候要保留正負號, 但是比較時以絕對值為準。 WorksheetFunction.Max() 或WorksheetFunction.Min() 指令好像不能直接比較絕對值, 所以求教...

mxg825

1. Sub mxg()
   
2. Dim X As Long, Y As Long
   
3. Dim Aran As Range, Bran As Range
   
4. Y = Range("B65536").End(xlUp).Row
   
5. For X = 3 To Y
   
6. Set Aran = Cells(X - 1, 2)
   
7. Set Bran = Cells(X, 2)
   
8.     If IsNumeric(Aran) And IsNumeric(Bran) Then '是否数值
   
9.      If Aran > Bran Then
   
10.       Cells(X, 5) = -(Application.Max(Abs(Aran), Abs(Bran)) - Application.Min(Abs(Aran), Abs(Bran)))
    
11.       Else
    
12.       Cells(X, 5) = Application.Max(Abs(Aran), Abs(Bran)) - Application.Min(Abs(Aran), Abs(Bran))
    
13.       End If
    
14.     Else
    
15.       Cells(X, 5) = "无效"
    
16.     End If
    
17. Next
    
18. End Sub
    

复制代码

如果 B列没有负数...ABS() 可以不用!

1. Sub mxg2()
   
2. Dim X As Long, Y As Long
   
3. Dim Aran As Range, Bran As Range
   
4. Y = Range("B65536").End(xlUp).Row
   
5. For X = 3 To Y
   
6. Set Aran = Cells(X - 1, 2)
   
7. Set Bran = Cells(X, 2)
   
8.     If IsNumeric(Aran) And IsNumeric(Bran) Then '是否数值
   
9.      If Aran > Bran Then
   
10.       Cells(X, 5) = -(Application.Max(Aran, Bran) - Application.Min(Aran, Bran))
    
11.       Else
    
12.       Cells(X, 5) = Application.Max(Aran, Bran) - Application.Min(Aran, Bran)
    
13.       End If
    
14.     Else
    
15.       Cells(X, 5) = "无效"
    
16.     End If
    
17. Next
    
18. End Sub
    

复制代码

monstrooilis

mxg825 发表于 2011-9-22 00:28
如果 B列没有负数...ABS() 可以不用!

謝謝回覆! 請問要如何在新一欄把各個數值列出呢? 例如在column G 寫出全部的最大差值, H 寫出全部的最小差值

新手看代碼很頭大, 想請教大大的哪一行代碼是把每5個數分成一組比較?

mxg825

Sub mxg2()
Dim X As Long, Y As Long
Dim Aran As Range, Bran As Range
Y = Range("B65536").End(xlUp).Row
For X = 3 To Y
Set Aran = Cells(X - 1, 2)
Set Bran = Cells(X, 2)
    If IsNumeric(Aran) And IsNumeric(Bran) Then '是否数值
     If Aran > Bran Then
      Cells(X, 5) = -(Application.Max(Aran, Bran) - Application.Min(Aran, Bran))
      Else
      Cells(X, 5) = Application.Max(Aran, Bran) - Application.Min(Aran, Bran)
      End If
    Else
      Cells(X, 5) = "无效"
    End If
Next
End Sub


改上面红色地方：

[B] 为B 列 对应数值为第二列 [2]

[5] 为填充结果列  5表示 第五列 E列

mxg825

你把结果 用公式写出来。。或把过程写出来。。

monstrooilis

請看一下這個代碼:

1. Sub max1()
   
2. Sheet1.Activate
   
3. Application.ScreenUpdating = False
   
4. Sheet1.UsedRange.Offset(0, 5).ClearContents
   
5. R = [e65536].End(3).Row
   
6. For i = 2 To R
   
7.     If IsNumeric(Cells(i, 5)) Then Cells(i, 8) = Cells(i, 5) Else: Cells(i, 8) = ""
   
8. Next
   
9. For i = 2 To R Step 5
   
10.     Cells(i, 6) = Application.Max(Range(Cells(i, 8), Cells(i + 4, 8)))
    
11.     Cells(i, 7) = Application.Min(Range(Cells(i, 8), Cells(i + 4, 8)))
    
12. Next
    
13. [f1].Resize(1, 2) = Array("max", "min")
    
14. Sheet1.UsedRange.Offset(0, 7).ClearContents
    
15. Application.ScreenUpdating = True
    
16. End Sub
    
17. Sub max2()
    
18. Sheet1.Activate
    
19. arr = Range("e2", [e65536].End(3).Offset(5))
    
20. For i = 1 To UBound(arr)
    
21.     If IsNumeric(arr(i, 1)) Then arr(i, 1) = arr(i, 1) Else: arr(i, 1) = ""
    
22. Next
    
23. ReDim crr(1 To UBound(arr), 1 To 2)
    
24. For i = 1 To UBound(arr) - 5 Step 5
    
25.     ReDim brr(1 To 5, 1 To 1)
    
26.     For k = 0 To 4
    
27.         brr(k + 1, 1) = arr(k + i, 1)
    
28.     Next
    
29.     crr(i, 1) = WorksheetFunction.Max(brr)
    
30.     crr(i, 2) = WorksheetFunction.Min(brr)
    
31. Next
    
32. [f1].Resize(1, 2) = Array("max", "min")
    
33. [f2].Resize(UBound(arr), 2) = crr
    
34. End Sub
    

复制代码

這樣運行的話, 找出的最大和最小相差值是包括正負號的, 但是我想以絕對值來比較, 比如第三組(E12:E16) 它找到最大是0.67, 最小是-0.28
但我想得出的結果是:  最大差值是0.67, 而最小差值則是 -0.02, 不知道該如何修改...

VBA80第2关

27行  brr(k + 1, 1) = arr(k + i, 1)

改为 brr(k + 1, 1) =ABS( arr(k + i, 1))

试试看  没你的附件 没办法测试