LBJisgod5566 wrote:
請問程式要怎麼寫阿...(恕刪)
直接寫給您吧，這不是3言2語就能教的，有興趣的話，先去看一下統計學的排列組合
為了方便您看懂，這用迴圈式，是比較簡單的寫法
雖然這樣有點慢，但每秒還是能計算大約550萬種組合
範列：N個數字(需大於5個)，取5個，在所有不重覆組合中，找出所有合計168的組合(想改成字串組合也可以)
把要排列組合的放在a欄，a1~a??
("3+2+1"=>"1+2+3"=>"2+1+3"，在這個程式中，這樣算是重覆喔，所以只會列出一筆)
Sub test()
Dim data() As Variant, total As Long, ok As Long
'如果組合太多超過2,147,483,647種
'as long 要改成 as double 或是as Currency，不然會造成溢位錯誤
data = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
t = Timer
For i = 1 To UBound(data)
For j = i + 1 To UBound(data)
For k = j + 1 To UBound(data)
For l = k + 1 To UBound(data)
For m = l + 1 To UBound(data)
If data(i) + data(j) + data(k) + data(l) + data(m) = 168 Then
'找到的結果，建議不要一筆一筆列出，數字多的話，會嚴重影響計算速度，請先丟陣列，最後再一次輸出
'如果只要找一筆，這裡加一行exit sub 直接跳出迴圈即可，就算2000筆，也大約1秒就有結果了
'想列出全部組合的話，a欄超過500筆，用這個慢速程式，只會等到到天荒地老…
'想看全部組合只適合數量少約300筆內，才可以用debug.print 測試看結果，或是把結果丟到儲存格裡面
'Debug.Print data(i), data(j), data(k),data(l), data(m)
ok = ok + 1
End If
total = total + 1
Next m, l, k, j, i
Debug.Print "計算時間經過" & Timer - t
Debug.Print "合計不重覆組合共" & total & "組"
Debug.Print "加總168成立共" & ok & "組"
End Sub
我在 #5 有寫我的程式構想。
20組數字，挑選其中來組成目標數 10000。
1. 20組數字先進行排序
516,528,561,688,715,740,797,803,820,891,1059,1077,1137,1192,1330,1372,1379,1401,1466,1467
2. 由小加到大，到第 13 組破目標值 10000。
3. 由大加到小，到第 8 組破目標值 10000。
4. 使用排列組合 20挑8,20挑9,20挑10,20挑11,20挑12,20挑13 的各種來嘗試達到目標數。總共有 850,136 種組合。
最後就是用程式來做這個排列組合 20挑8,20挑9,20挑10,20挑11,20挑12,20挑13 的各種來嘗試達到目標數10000。
不想唸物理了...
wenwenwen wrote:
我在 #5 有寫我的程式構想。
2. 由小加到大，到第 13 組破目標值 10000。 ...(恕刪)
我有用您的構想試寫一下，因為由小加到大、由大加到小，很好寫
先排序+一個迴圈就解決了
但發現一個問題
範例，找總合15，由小加到大(1 3 5 7 9 )
1+3+5=9
1+3+5+7=16
有發現到了嗎??
由小加到大，您可以找到 9 跟 16 ，就是找不到15
但 3+5+7=15，是存在的
如果加總時，沒有剛剛好加到所要的數值時，只能找到最接近的
解決方式就是
一、隨意減二個值 或更多
二、再把減掉的，加總
三、搜尋數列中，減掉的加總，有沒有這個數值
四、如果沒有，再回到一，減更多
因判斷的結構，不容易說明，所以最後用迴圈的方式解釋
以下這是用您的構想寫的，您參考看看吧
Sub test()
Set data = CreateObject("system.collections.arraylist")
For i = 1 To Range("A1").End(xlDown).Row
data.Add Cells(i, 1).Value
Next
data.Sort
'由小排序到大
'這裡多加一行 'data.Reverse ，可變成大排到小
For j = 0 To data.Count - 1
total = total + data(j)
If total = 10000 Then
For k = 0 To j
Debug.Print data(k),
Next
Exit Sub
end if
'if total >10000 then
'如果照順序加沒有結果，在這裡，要加程式碼另外處理
'end if
Next
End Sub
至於上一個迴圈那個範例，您想取幾個
就多加幾個迴圈就可以了，6個就6層，7個就7層
====================================
補充另一種方式，找出"所有可能"，結果可能是1個數字，也可能是10個數字的組合 或 更多組數的組合
不過，超級慢~~~~，如果超過100個數字，不想只找一組，想看全部組合
還是別用了，基本上跑不完的…
Sub test()
Dim data As Variant, targetsum As Variant, total As Long, i As Long, ok As Long
data = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("b:z").Clear
For i = 1 To UBound(data)
ReDim targetsum(1 To i)
Call findCombin(data, targetsum, i, total, 1, 1, ok)
Next i
Debug.Print "總共" & total & "種不重覆組合"
Debug.Print "合計10000共" & ok & "種組合"
End Sub
Sub findCombin(data As Variant, targetsum As Variant, j As Long, total As Long, k As Long, n As Long, ok As Long)
Dim i As Long
For i = k To UBound(data)
targetsum(n) = data(i)
If n = j Then
total = total + 1
'設定目標值(預設10000)
If Application.WorksheetFunction.Sum(targetsum) = 10000 Then
ok = ok + 1
Range("c" & ok).Resize(1, j) = targetsum
If ok = 1 Then End '找到一組就結束，整行刪掉就是找全部，也可以自行設定要幾組
End If
Else
Call findCombin(data, targetsum, j, total, i + 1, n + 1, ok)
End If
Next i
End Sub
內文搜尋
從 APP 打開
X