麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何計算每個欄的累計最大失分 [打印本頁]

作者: cdkee 時間: 2016-8-14 09:35 標題: 如何計算每個欄的累計最大失分

請教大大以下如何利用VBA做到，謝謝!
7列=D欄中累計最大失分(黃色部份)
8列=D欄中累計第2大失分(綠色部份)
9列=D欄中累計第3大失分(橙色部份)
[attach]24926[/attach]

作者: VBALearner 時間: 2016-8-14 10:16

回復 1# cdkee

首先由上而下把創新高的儲存格挑出來記錄好數值，再把兩兩創新高儲存格中間範圍的最小值儲存格挑出來計算最大失分，最後再排序出最小值、第二小、第三小的數字顯示出來即可

作者: cdkee 時間: 2016-8-14 16:31

回復 2# VBALearner

始終弄不清，可否請各位大大示範，謝謝!

作者: VBALearner 時間: 2016-8-14 20:36

本帖最後由 VBALearner 於 2016-8-14 20:39 編輯

該程式碼設定您的15個數據在A1到A15，看懂程式碼後可自行更改Cells(?,?)
也希望有高手能來參與討論簡化或提出更厲害的方法OwO

Option Base 1
Sub test()
Dim NewHigh, NewLow, i, j, k As Integer: NewHigh = 0: NewLow = 0: j = 1: k = 1
Dim NewLowRecord(15), FinalRecord()
For i = 2 To 15
If Cells(i, 1).Value >= NewHigh Then '紀錄創新高壞持平
NewHigh = Cells(i, 1).Value
If Not IsEmpty(NewLowRecord(1)) Then '判斷非連續創高
ReDim Preserve FinalRecord(j)
FinalRecord(j) = Application.Small(NewLowRecord, 1) '紀錄創高區間內所有拉回的最小值
Erase NewLowRecord '清空拉回值暫存
j = j + 1
k = 1
End If
Else
NewLow = Cells(i, 1).Value - NewHigh
NewLowRecord(k) = NewLow '紀錄拉回值(與上一新高之差)
k = k + 1
End If
Next
MsgBox "最大拉回 : " & Application.Small(FinalRecord, 1)
MsgBox "第二大拉回 : " & Application.Small(FinalRecord, 2)
MsgBox "第三大拉回 : " & Application.Small(FinalRecord, 3)
End Sub

複製代碼

[attach]24931[/attach]
回復 3# cdkee

作者: GBKEE 時間: 2016-8-15 08:31

回復 4# VBALearner
換湯不換藥,來湊一腳

'Option Base 1 '所修改的程式可不必 Option Base 1
Sub Ex()
Dim NewHigh As Long, NewLow As Long, LowRecord As Long, i As Integer, j As Integer
Dim FinalRecord()
' NewHigh = 0: NewLow = 0 ' **變數型態為數字,程式一開始皆為0值
For i = 2 To 15
If Cells(i, 1).Value >= NewHigh Then '紀錄創新高壞持平
NewHigh = Cells(i, 1).Value
If LowRecord <> 0 Then '判斷非連續創高
ReDim Preserve FinalRecord(0 To j)
FinalRecord(j) = LowRecord
LowRecord = 0 '清空拉回值暫存
j = j + 1
End If
Else
NewLow = Cells(i, 1).Value - NewHigh
LowRecord = IIf(LowRecord >= NewLow, NewLow, LowRecord)
End If
Next
MsgBox "最大拉回 : " & Application.Small(FinalRecord, 1)
MsgBox "第二大拉回 : " & Application.Small(FinalRecord, 2)
MsgBox "第三大拉回 : " & Application.Small(FinalRecord, 3)
End Sub

複製代碼

作者: cdkee 時間: 2016-8-15 09:52

回復 4# VBALearner
回復 5# GBKEE
謝謝兩位大大指導!
因為會不斷有多組累計分數加入，再請教如何將結果放在7,8,9列，謝謝!
[attach]24935[/attach]

作者: VBALearner 時間: 2016-8-15 13:34

回復 6# cdkee

放在7,8,9列

Cells(7,??) = Application.Small(FinalRecord, 1)
Cells(8,??) = Application.Small(FinalRecord, 2)
Cells(9,??) = Application.Small(FinalRecord, 3)

複製代碼

不斷往下統計新增的資料

Do while Cells(i,??).value <> ""
...
i=i+1
loop

複製代碼

作者: cdkee 時間: 2016-8-15 14:07

回復 7# VBALearner

謝謝大大再次教導!
例子是向右增加"累計分數"組，每組都在7,8,9列顯示結果，應如何改寫，謝謝!

作者: VBALearner 時間: 2016-8-15 14:58

本帖最後由 VBALearner 於 2016-8-15 15:02 編輯

回復 8# cdkee

i是資料最左邊的起始欄位編號，D欄就是4
資料位置跟...的部分就依照你的需要自行改寫吧~

i = 4
do while cells(20,i) <> ""
...'計算失分程式
cells(7,i) = application.worksheetfunction.Small(FinalRecord,1)
cells(8,i) = application.worksheetfunction.Small(FinalRecord,2)
cells(9,i) = application.worksheetfunction.Small(FinalRecord,3)
i = i + 1
loop

複製代碼

作者: cdkee 時間: 2016-8-15 17:36

只有第1組計算正確，其他組都計算不正確，請大大幫忙應該如何改，謝謝!
[attach]24945[/attach]

作者: cdkee 時間: 2016-8-15 19:03

回復 7# VBALearner
回復 5# GBKEE
用GBKEE版大的去修改，也是不行，請教各大大如何改寫，謝謝!

[attach]24946[/attach]

作者: VBALearner 時間: 2016-8-15 23:10

回復 11# cdkee

喔...我似乎有點誤會你的意思，我以為是創新高後來拉回多少的紀錄...
我想請問如果遇到以下狀況您希望儲存格如何顯示?
1.資料:0,100,200,300,400,500,600,700,800,900 (無失分)
2.資料:0,100,200,300,400,1000,200,200,200,200 (無大二大失分)
3.資料:0,1000,500,500,2000,1000,1000,500,500,500 (無大三大失分)

作者: cdkee 時間: 2016-8-15 23:32

回復 12# VBALearner

謝謝大大回覆!
(無失分)>>3個(列7,8,9)都顯示0
(無第二大失分)>>列8,9都顯示0
(無第三大失分)>>列9都顯示0

作者: VBALearner 時間: 2016-8-16 00:48

回復 13# cdkee
不好意思，我決定先假設存在第一大失分與第二大失分的情況來寫程式，不做Debug，也暫時放棄嘗試計算第三大失分
麻煩版上各位高手也來集思廣益，我自認我想的這個程式似乎不是很聰明，還需各位激盪腦力!
麻煩問題提問者，看懂這個程式的邏輯後，再試試看如何寫出第三大失分，我就先努力到這了，準備休息睡覺TwT
本程式設定資料位在A1.resize(20,1)，針對此資料範圍做計算。重點在於計算大二大失分時，資料不能與第一大失分的資料範圍有所重複，否則將計算錯誤，因此予以紀錄第一大失分的上下界來做第二次計算的條件判讀。文末附有測試檔，歡迎下載改良!

Sub 最大失分()
Dim 上界, 下界, 紀錄上界, 紀錄下界, i, j, k, m, n, x, 失分, z As Integer
上界 = 21
下界 = 0
失分 = 0
For m = 1 To 2
For i = 1 To 19
For j = i + 1 To 20
差值 = (Cells(i, 1) - Cells(j, 1))
If 差值 > 0 And 差值 > 失分 Then
If i < 上界 And j < 上界 Then
失分 = 差值
紀錄上界 = i
紀錄下界 = j
ElseIf i > 下界 And j > 下界 Then
失分 = 差值
紀錄上界 = i
紀錄下界 = j
End If
End If
Next
Next
上界 = 紀錄上界
下界 = 紀錄下界
MsgBox "第" & m & "大失分 : " & 失分
失分 = 0
Next
End Sub

複製代碼

[attach]24947[/attach]

作者: cdkee 時間: 2016-8-16 10:58

本帖最後由 cdkee 於 2016-8-16 11:00 編輯

回復 14# VBALearner

感謝大大幫忙!已經幫我節省了很多工作時間。
經過修改和測試後，有2組(第3組,第5組)計算錯誤，見附件，煩請教各位大大幫忙如何修改，謝謝!
[attach]24948[/attach]

作者: VBALearner 時間: 2016-8-16 11:44

本帖最後由 VBALearner 於 2016-8-16 11:59 編輯

回復 15# cdkee

您還真是不厭其煩的想達成這個目標呢-w-
再幫您努力一下吧，有始有終。對了可以問你要怎麼同時回復兩個人嗎xD? 我看到你有一篇回復的回復標籤有我和超級版主，如何做到?
這是最終版了，可以計算3大失分，一樣文末有附檔。程式邏輯有點難解釋，主要是根據顏色區塊的不重複性，來做有效值得篩選判斷，因此在計算第一大失分時，條件是最寬鬆的，因為此時還沒有出現顏色區塊(select case m = 1)。計算第二大失分時，要避免i,j值跨過或落在黃色區塊，因此i,j值只有兩種狀況: 1.<黃色區塊的上界 2.>黃色區塊的下界。根據這種邏輯繼續去做第三大失分的邏輯判斷，計算第3大失分時，已經有黃顏與綠色兩大區塊，因此會有兩個上界和兩個下界，此時應先判斷黃色或綠色區塊誰在上方(select case 3裡面的if 上界(3) > 下界(2)...)，再做失分計算判斷，此時資料有經被兩大顏色區塊切成3份，因此新的i,j值變成要落在這3份非顏色區塊裡面才是有效值，否則將與黃綠色區塊重複，大概的邏輯是如此，有些困難，但動手在紙上把圖畫出來，把上界和下界標上去應該會好懂些，此外，若無失分，會顯示失分為0。跟之前一樣，歡迎高手來改寫我這落落等的程式哈哈哈!!!

Dim 欄, 失分, 紀錄上界, 紀錄下界, 上界(1 To 3), 下界(1 To 3), i, j, Z As Integer
Sub 計算失分()
紀錄上界 = 0
紀錄下界 = 0
For 欄 = 1 To 7
For m = 1 To 3 '計算第m大失分
上界(m) = 紀錄上界
下界(m) = 紀錄下界
失分 = 0
For i = 1 To 14
For j = i + 1 To 15
Z = (Cells(i, 欄) - Cells(j, 欄))
If Z > 失分 Then
Select Case m
Case 1 '第一大失分計算
Call 紀錄
Case 2 '第二大失分的限制條件
If i < 上界(m) And j < 上界(m) Then
Call 紀錄
ElseIf i > 下界(m) And j > 下界(m) Then
Call 紀錄
End If
Case 3 '第三大失分的限制條件
If 上界(3) > 下界(2) Then
If i < 上界(2) And j < 上界(2) Then
Call 紀錄
ElseIf i > 下界(2) And j > 下界(2) And i < 上界(3) And j < 上界(3) Then
Call 紀錄
ElseIf i > 下界(3) And j > 下界(3) Then
Call 紀錄
End If
ElseIf 上界(2) > 下界(3) Then
If i < 上界(3) And j < 上界(3) Then
Call 紀錄
ElseIf i > 下界(3) And j > 下界(3) And i < 上界(2) And j < 上界(2) Then
Call 紀錄
ElseIf i > 下界(2) And j > 下界(2) Then
Call 紀錄
End If
End If
End Select
End If
Next
Next
Cells(6 + m, 欄 + 12) = -失分 '貼上工作表，位置自行更改
Next
Next
End Sub
Sub 紀錄()
失分 = Z
紀錄上界 = i
紀錄下界 = j
End Sub

複製代碼

[attach]24951[/attach]

作者: cdkee 時間: 2016-8-16 13:09

回復 16# VBALearner
謝謝大大不厭小弟煩而幫助，大大的最終版小弟仍在了解中。
想表示回覆哪位大大，只要在那位大大留言按"回覆"，之後COPY個URL，再複製到自己的回覆內容就可以。
再謝謝VBALearner大大!

作者: stillfish00 時間: 2016-8-16 14:16

回復 15# cdkee
看不懂你的邏輯
第一組2016/5/5開始 1000,900,700,800,600,300
700到800有得分啊，結果你用1000-300=700失分
而不是分為 1000-700 , 800-300 這兩組失分

作者: cdkee 時間: 2016-8-16 14:24

回復 16# VBALearner

計算列20至列813都無問題
計算列20至列814出"溢位錯誤"
請教各大大我的修改那裡錯，謝謝!
[attach]24952[/attach]

作者: cdkee 時間: 2016-8-16 14:29

回復 cdkee
看不懂你的邏輯
第一組2016/5/5開始 1000,900,700,800,600,300
700到800有得分啊，結果你用 ...
stillfish00 發表於 2016-8-16 14:16

因為是要累計最大失分，不是要連續最大失分。

作者: stillfish00 時間: 2016-8-16 17:21

回復 20# cdkee
插入一般模組，貼上下面code

Function FindMaxLoss(rngInput As Range, Optional order As Integer = 1)
On Error GoTo ErrHandle
Dim ar, arLoss
ar = Application.Transpose(rngInput)
ReDim arLoss(1 To UBound(ar))
Dim i, count As Integer, sum As Double
Dim indMin As Long, indMax As Long
indMin = 1: indMax = 1
i = 2
Do While i <= UBound(ar)
If ar(i) < ar(indMin) Then indMin = i
If ar(i) > ar(indMax) Or i = UBound(ar) Then
If indMin <> indMax Then
count = count + 1
arLoss(count) = ar(indMin) - ar(indMax)
i = indMin
End If
indMin = i
indMax = i
End If
i = i + 1
DoEvents
Loop
ReDim Preserve arLoss(1 To count)
FindMaxLoss = Application.WorksheetFunction.Small(arLoss, order)
Exit Function
ErrHandle:
FindMaxLoss = CVErr(xlErrValue)
End Function

複製代碼

D7填上公式  =FindMaxLoss(D$20:D$34,1)
D8填上公式  =FindMaxLoss(D$20:D$34,2)
D9填上公式  =FindMaxLoss(D$20:D$34,3)
向右拖曳填滿公式

作者: cdkee 時間: 2016-8-16 18:40

回復 21# stillfish00

謝謝大大幫助!
測試後，發現第一最大失分，會以0減最大累計分數，請教如何修改?謝謝!

作者: cdkee 時間: 2016-8-16 18:55

回復 21# stillfish00

作了以下修改，謝謝各位大大幫忙!
D7填上公式  =FindMaxLoss(D$20:D$34,2)
D8填上公式  =FindMaxLoss(D$20:D$34,3)
D9填上公式  =FindMaxLoss(D$20:D$34,4)

作者: VBALearner 時間: 2016-8-16 20:42

回復 19# cdkee

我說您也稍微了解一下VBA基本的型態限制吧= ="
用integer無法計算到這麼大的數字，宣告變數要改成哪個型態網站上有寫
http://edisonx.pixnet.net/blog/post/42112370-vba-%E5%9F%BA%E6%9C%AC%E8%B3%87%E6%96%99%E5%9E%8B%E6%85%8B

作者: cdkee 時間: 2016-8-16 22:36

回復 24# VBALearner

仍然了解中，謝謝大大指導。

作者: cdkee 時間: 2016-8-17 10:04

回復 21# stillfish00

大大的沒有問題，今天正常了。

作者: 准提部林 時間: 2016-8-17 22:45

還是有點看不懂，大約也寫一個：

Function GetLoseVal(xRng As Range, xInd%)
Dim Arr, xMin, i&, j&, k%, N%, xD
xMin = "": GetLoseVal = "": Arr = xRng.Value
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
For j = i + 1 To UBound(Arr)
If Arr(j, 1) >= Arr(i, 1) Then Exit For
If Arr(j, 1) < xMin Then k = j: xMin = Arr(j, 1)
Next
If xMin <> "" Then N = N + 1: xD(N) = xMin - Arr(i, 1): i = k: xMin = ""
Next
If xInd <= N Then GetLoseVal = Application.Small(xD.items, xInd)
End Function

複製代碼

Ｄ７公式：=GetLoseVal(D$20:D$34,ROW(A1))　右拉下拉
　
　

作者: cdkee 時間: 2016-8-18 00:37

還是有點看不懂，大約也寫一個：

Ｄ７公式：=GetLoseVal(D$20$34,ROW(A1))　右拉下拉
　
　
准提部林發表於 2016-8-17 22:45

謝謝准提部林版大!是的，就是這樣。
請教大大，D7的公式中，用ROW(A1)有什麼作用?

作者: 准提部林 時間: 2016-8-18 09:34

回復 28# cdkee

=ROW(A1) >>>> = 1
下拉則遞增
=ROW(A2) >>>> = 2
...
...

作者: cdkee 時間: 2016-8-18 11:51

回復 29# 准提部林

學多樣技巧，謝謝版大教導!

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)