(5/24 小更新)Excel多組數字挑選加總為指定數值的方法(vba 範例)

(***此文只在mobile01發表,如轉貼到其它論譠、bolg,請附上來源網址,謝謝***)

(5/24 更新程式碼,請參考4樓)

這篇有人問,不過提問者自己也是高手,自己有寫程式解決了,我只是提供另一種寫法而己
(離上次回答問題,居然過3年了)
http://www.mobile01.com/topicdetail.php?f=511&t=3432008&p=1

這篇也有人問(雖然提問者,主要是要問規劃求解)
http://www.mobile01.com/topicdetail.php?f=511&t=5022284&p=1#62843370

因為2篇標題幾乎一樣
所以把3年前寫的程式,把2^n-1 ,c(n,m) 2個功能合併,
把計算c(n,m)的超多層迴圈,也用副程式代替,縮短程式碼
順便修改一些地方,提升至少超過簡易版2倍以上的計算速度


第一篇 20個數字,搜尋加總10000,可成立218個組合
計算次數1048575,程式運行時間約4秒

第二篇 23個數字,搜尋加總7143,可成立180個組合,
計算次數8388607,程式運行時間約30秒(未修正前約80秒)


如果不找全部組合,只找一組,或限定搜尋組數時,剛好小於最大成立組合
或限定每次取出數字個數(3個 or 5個 or ...其它)
基本上,秒解

不過,那種幾百個數字的,還是別用了
我這個 excel vba小品程式,寫的爛,計算速度太慢,電腦跑不動的…
有興趣的拿去玩吧,資料量不多的話,用vba會比規劃求解快很多

程式功能,找出這2個排列組合公式,加總條件成立的組合
2^n-1
c(n,m)=n!/((n-m)!m!)

=========================================================================

'程式用法:
'a1~a??? 放數字(不用排序)
'b1 目標值
'b2 限定每組個數(不填,找所有組合)
'b3 限定最大搜尋組數(不填,找所有組合)
建議先填入一個小一點的數字測試
或自行如入計時功能超過時間就自動結束程式
避免資料太多跑不完






Sub test()
Dim data As Variant, targetsum As Variant, total As Long, i As Long, ok As Long, target As Long, limited As Integer, maxcombin As Integer, start As Integer, startend As Integer
Columns("d:z").Clear'這行視情況,請自行增加清除範圍
data = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
If Range("b1") = 0 Then End
target = Range("b1"): limited = Range("b2"): maxcombin = Range("b3"): Range("b4") = "": Range("b5") = "": Range("d1") = Format(Now(), "hh:mm:ss")
If limited = 0 Then
start = 1: startend = UBound(data)
Else
start = Range("b2"): startend = start
End If
For i = start To startend
ReDim targetsum(1 To i)
Call findCombin(data, targetsum, i, total, 1, 1, ok, target, limited, maxcombin)
If start startend Then Range("b5") = Int((i / startend * 100) + 0.5) & "%"
Next i
Range("b5") = "100%": Range("d2") = Format(Now(), "hh:mm:ss"): Debug.Print total
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, target As Long, limited As Integer, maxcombin As Integer)
Dim i As Long, tempsum As Long
'(20180813更新,注意,如果數值有小數點,請把上面這行改成=> Dim i As Long, tempsum,如果目標值只是一般數字改成tempsum As Double 或是 tempsum As single也可以)
For i = k To UBound(data)
targetsum(n) = data(i): tempsum = 0
If n = j Then
total = total + 1
For s = 1 To UBound(targetsum)
tempsum = tempsum + targetsum(s)
Next s
If tempsum = target Then
'如果目標值有範圍限制
'例如:10<目標值<88
'整個程式只需修改上面那1行if判斷句即可
'至於怎麼改,請自行練習

ok = ok + 1: Range("e" & ok).Resize(1, j) = targetsum
If (ok = maxcombin And maxcombin 0) Then
Range("b4") = ok: Range("b5") = "100%": Range("d2") = Format(Now(), "hh:mm:ss"): Debug.Print total
End
End If
Range("b4") = ok
End If
Else
Call findCombin(data, targetsum, j, total, i + 1, n + 1, ok, target, limited, maxcombin)
End If
Next i
End Sub


附加壓縮檔: 201612/mobile01-f62b004a35b1e9bce6be0061f7b78b63.zip


如果沒有目標值,只想看所有的不重覆排列組合,目標值保持空白,程式碼修改如下
(點下可看大圖)

2016-12-28 2:46 發佈
如果數字可重複選取,例如 6 = 3 + 3,可解嗎?
Wei_1144 wrote:
如果數字可重複選取,例如 6 = 3 + 3,可解嗎?...(恕刪)


不太懂耶??

如果您問的是 3,3,1,2,3,3 這串數字中有重複項目,找加總為6的組合,這個範例可解
因為 2^n-1 , c(n,m) 這2個公式,是看位置來組合的,不管內容

如果您問的是 3,3,1,2,3,3 這串數字,假設每次取2個的話 11,22,31,32……
每個字都可以重複選,這個範例不可解,那是另一個公式。

又翻一下以前的統計學課本,才發現還細分成排列公式,組合公式
雖然確定程式的結果是正確的

但臨時抱佛腳看課本的說明是不是正確我就不確定了
離開學校太久了,現在看起來那些內容像天書一樣,有錯請原諒我
真搞不懂我以前我以前是怎麼畢業的,為什麼看的懂那些內容
稍微更新一下,多加上列出,編號(名稱、貨號)的功能
這樣可以多一個排列方式的選擇



'=========================================================
Sub test()

Dim data(), targetsum() As Single, item_name() As String, lastrow As Integer
Dim total As Long, i As Integer, ok As Integer, target As Single, limited As Integer, maxcombin As Integer, start As Integer, startend As Integer, tolerance As Single

Columns("E:Z").Clear

ttt = Timer

lastrow = Range("A2").End(xlDown).Row
ReDim data(1 To 2, 1 To lastrow - 1)

For d = 1 To lastrow - 1
data(1, d) = Cells(d + 1, 2).Value
' data(2, d) = Cells(d + 1, 1).Value
Next d

If Range("C1") = 0 Then End

target = Range("C1"): tolerance = Range("C2"): limited = Range("C3"): maxcombin = Range("C4")
Range("C5") = "": Range("C6") = "": Range("E1") = Format(Now(), "hh:mm:ss")

If limited = 0 Then
start = 1: startend = UBound(data, 2)
Else
start = limited: startend = start
End If

For i = start To startend
ReDim targetsum(1 To i)
' ReDim item_name(1 To i)
Call findCombin(data, targetsum, item_name, i, total, 1, 1, ok, target, limited, maxcombin, tolerance)
If start startend Then Range("C6") = Int((i / startend * 100) + 0.5) & "%請耐心等待"
Next i
'20190524 更新,無解時,find_name副程式會出錯(另一種方式沒問題)
If ok <> 0 Then Call find_name '20190524 修正
'<>,這是全形符號,複製後請自行改成半形
Range("C6") = "100%計算結束": Range("E2") = Format(Now(), "hh:mm:ss")
Debug.Print total, Timer - ttt

End Sub

Sub findCombin(data(), targetsum() As Single, item_name() As String, j As Integer, total As Long, k As Integer, n As Integer, ok As Integer, target As Single, limited As Integer, maxcombin As Integer, tolerance As Single)

Dim i As Integer, tempsum As Double

For i = k To UBound(data, 2)

targetsum(n) = data(1, i): tempsum = 0
' item_name(n) = data(2, i)

If n = j Then
total = total + 1

For s = 1 To UBound(targetsum)
tempsum = tempsum + targetsum(s)
Next s

If tempsum = target Then
ok = ok + 1

Range("G" & ok).Resize(1, j) = targetsum
' Range("F" & ok) = Join(item_name, ",")

If (ok = maxcombin And maxcombin 0) Then
Range("C5") = ok: Range("C6") = "100%計算結束": Range("E2") = Format(Now(), "hh:mm:ss"): Debug.Print total
If ok <> 0 Then Call find_name '20190524 修正
'<>,這是全形符號,複製後請自行改成半形
End
End If

Range("c5") = ok

End If

Else
Call findCombin(data, targetsum, item_name, j, total, i + 1, n + 1, ok, target, limited, maxcombin, tolerance)
End If

Next i

End Sub

Sub find_name()

Dim lastrow As Integer, lastcol As Integer, n As Object, name_data() As String
Set n = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False

lastrow = Range("A1").End(xlDown).Row
For i = 2 To lastrow
n.Add Str(Cells(i, 2)), Cells(i, 1)
Next i

lastrow = Range("g1").CurrentRegion.Rows.Count '20190524 修正
For i = 1 To lastrow
lastcol = Range("G" & i).End(xlToRight).Column
ReDim name_data(1 To lastcol - 6)

For j = 7 To lastcol
name_data(j - 6) = n(Str(Cells(i, j)))
Next j

Cells(i, 6) = Join(name_data, ",")

Next i

Set n = Nothing
Application.ScreenUpdating = True

End Sub
'=========================================================

不過編號有2種處理方式,預設是用 find_name() 副程式
排列組合完之後,再找編號,程式比較快
以這個範例中的23個數字來說,8百多萬次計算
先排列後找編號,約30~40秒
排列過程中順便排列編號,約50~60秒


什麼時候要用比較慢的方法找編號呢?
就是當編號 或 數值 中,其中一個有重覆的資料時
例如
同編號有2個(或以上)相同數值
同數值有2個(或以上)相同編號
這在材料、原料,選擇上常常發生

改成另一種慢的方式很簡單,只要把以下四行的禁用取消
然後再把 call find_name 2行禁用,就可以了



各位在圖片看到的誤差值(+ -)功能
在上傳的程式碼、夾檔中,我改掉了,沒作用
只有保留變數值tolerance

要誤差值功能,只需要改一行 if (如下圖),其它都不用改
可自行把tolerance變數,代入程式碼中,或直接用range("c2")的值也可以(但會變慢一些)




另外自從2016上傳舊範例後,有不少人在私訊問我,幫忙改出誤差值,甚至願意付費

我寫這些亂七八糟的範例,不是為了打廣告、不是為了賺錢
如果真的想打廣告、賺錢,就會在簽名檔中加上個人blog、網址,別在私訊問我了

我寫的範例基本上功能完整,就是介面醜了點
要加上自行寫的表單、輸入介面…等等的,不會太難
像誤差值,就只要改1行,我還特別標出來
希望在看範例的同時,請自行思考一下如何改寫




(20150524 修正3行程式碼,請參考上面的註解,自行加入檔案中)
附加壓縮檔: 201810/mobile01-f4c375613236346e424eeff6b67a49e1.zip
感謝!搜尋到這篇對我幫助很大 感謝分享!!
snare worte:
稍微更新一下,多加上...(恕刪)

感謝樓主很棒的程式,我也有個小問題想請您幫忙,如果我想找出總和的目標值是介於某個數值區間,例如:8000~10000,請問如何修改程式?在此先謝謝您!
真的很棒,如果能找某個數值區間總和的目標值之所有可能組合就更加完美了!
heavenweaver worte:
如果我想找出總和的目標值是介於某個數值區間,例如:8000~10000,請問如何修改程式?在此先謝謝您!
真的很棒,如果能找某個數值區間總和的目標值之所有可能組合就更加完美了!...(恕刪)


讓程式不完美,是我故意的
請參考4樓,有說明改那一行程式碼




if 判斷式在excel中,不管是vba,還是公式,都是很基本、很重要的功能
請試著參考下面文章(或自行google 其它 if 範例)

https://docs.microsoft.com/zh-tw/dotnet/visual-basic/programming-guide/language-features/operators-and-expressions/logical-and-bitwise-operators

https://docs.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/comparison-operators


試著把下面這個小程式,從6改成3~9,一樣只需改1行程式碼
如果成功,那您就會改上面的程式了

(請使用f8逐行執行,了解程式的流程)
Sub test()

data = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

For Each target In data

If target = 6 Then MsgBox "find"

Next


End Sub
限制級
您即將進入之討論頁 需滿18歲 方可瀏覽。
根據「電腦網路內容分級處理辦法」修正條文第六條第三款規定,已於該限制級網頁,依台灣網站分級推廣基金會規定作標示。
評分
複製連結