[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数の値からある合計数に一致する組み合わせ』（シン）
500という合計値があり、現在20通りぐらいのランダムな値のなかで何れかの組み合わせで合計500になる組み合わせをもとめたい。
新規ブックにて試してください。
標準モジュール（Module1）に
'=================================================================
Option Explicit
Private svarray() As Variant
Private ccomb As Long
'=================================================================
Sub open_comb(myarray As Variant)
'組合せ処理のオ－プン
'myarray 組合せを行う配列
Dim ele As Variant
Dim g0 As Long
g0 = 0
Erase svarray()
For Each ele In myarray
ReDim Preserve svarray(1 To g0 + 1)
svarray(g0 + 1) = ele
g0 = g0 + 1
Next
ccomb = 0
End Sub
'=================================================================
Function get_comb(Optional flg As Long = 0) As Variant
'組合せリストを取り出す
'flg 0 次のデータ 1 桁スキップ
'get_comb 組合せの配列 Falseは、データの終わり
Dim g0 As Long
Dim g1 As Long
Dim ret As Boolean
Dim ans() As Variant
Dim oncnt As Long
ret = False
If flg = 0 Then
ccomb = ccomb + 1
If ccomb < (2 ^ UBound(svarray())) Then
ret = True
End If
ElseIf flg = 1 Then
oncnt = 0
For g0 = 0 To UBound(svarray()) - 1
If ccomb And 2 ^ g0 Then
oncnt = oncnt + 1
ccomb = ccomb And (Not 2 ^ g0)
Else
If oncnt >= 2 Then
ccomb = ccomb Or 2 ^ g0
ret = True
Exit For
End If
End If
Next
End If
If ret = True Then
g1 = 0
For g0 = 0 To UBound(svarray()) - 1
If ccomb And 2 ^ g0 Then
ReDim Preserve ans(1 To g1 + 1)
ans(g1 + 1) = svarray(g0 + 1)
g1 = g1 + 1
End If
Next
get_comb = ans()
Erase ans()
Else
get_comb = False
End If
End Function
'=================================================================
Sub close_comb()
'組合せ処理のクローズ
Erase svarray()
ccomb = 0
End Sub
別の標準モジュール（Module2）に
'=================================================================
Sub sample1()
Dim fit As Variant
Dim rw As Long
Dim mem As Variant
Dim flg As Long
Dim rng As Range
Set rng = Range("a1:a20")
With rng
.Formula = "=int(rand()*300)+1"
.Value = .Value
.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
End With
DoEvents
Range("e:e").Clear
fit = Application.InputBox("合計値を入力して", , , , , , , 2)
If TypeName(fit) <> "Boolean" Then
Call open_comb(rng.Value)
flg = 0
mem = get_comb(flg)
Do Until TypeName(mem) = "Boolean"
flg = 0
If Application.Sum(mem) = Val(fit) Then
Cells(rw + 1, 5).Value = Join(mem, "\")
rw = rw + 1
ElseIf Application.Sum(mem) > Val(fit) Then
flg = 1
End If
mem = get_comb(flg)
Loop
Call close_comb
End If
Set rng = Nothing
End Sub
としてSample1を実行してください。
A1:A20にランダムな数値が表示されます。 求める合計値を入力してください。 A1:A20の数値で、その合計値になる組合せをE列に表示します。 結果は、￥ 文字で区切られています。
試してみてください。
これでうまくいくようなら、ご自分の仕様に合わせて、 Module1を使って見みてください。標本数が30件までは使えます。
標本であるA1:A20は、昇順に整列されている必要があります
ichinose
とりあえず、頑張ってみます。
他掲示板ですが、参考になるかもしれません。 http://oshiete.goo.ne.jp/qa/5212312.html
他にもこの種の問題は過去に多くの相談例が ありますので検索されたらよいでしょう。
shibaraku
こんにちは よく質問に出るナップサック問題ですネ。ネットで調べるとよく分かるかと思います。 データ数20個の総組合せ数1,048,575、データ数30個の総組合せ数1,073,741,823となり、データ数を増やすと組合せ数は爆発的なかんじで増えます。
ナップサック問題をエクセルの機能で行うには、ソルバーを使用しますが、バージョン等によりデータ数の取扱数が変わります。 (PC本体のCPU及びソフトの性能向上等が関係すると思料します。) Windos XP Excel2003の場合データ数２０個(総組合せ数1,048,575)で約４０秒かかり、データ数２１個 (総組合せ数2,097,151)では2分以上かかり、かつ、解が出ない場合がある。 Windos Vista Excel2007 ソルバーを使用して、下記の35個データで値を求めてみました データ数35個(総組合せ数34,359,738,367)で値「500」を求めた。約11秒程度 =A1+A6+A7+A8+A9+A15+A18+A23+A26+A28+A32 データ数35個(総組合せ数34,359,738,367)で値「400」を求めた。約9秒程度 =A6+A8+A9+A11+A13+A22+A23+A24+A27+A29+A35 データ数35個(総組合せ数34,359,738,367)で値「300」を求めた。約9秒程度 =A13+A14+A15+A17+A18+A23+A27+A28+A29+A35
(Windos 7 Excel2007は、Windos Vista Excel2007より1～2秒程度早い感じ？)
A1～A35までのデータです。(参考) 17 20 33 43 50 55 58 60 73 24 35 15 10 40 28 36 42 53 38 19 21 27 38 41 29 64 10 28 37 31 30 26 18 44 14
ソルバーを使用する方法 B列空白 C1セルに=SUMPRODUCT(A1:A35,B1:B35) 「ソルバー：パラメータ設定」ダイアログボックス 目的セル：「C1」 目標値：「値」にレ点を入れる、右側の枡に検索する値を入力。例では500なので枡に500と入力 変化させるセル：B1:B35 「制約条件」の「追加」ボタンをクリックする。「制約条件の追加」ダイアログボックスが表示される。 「制約条件の追加」ダイアログボックスの"セル参照"に「B1:B35」と入力 「制約条件の追加」ダイアログボックスに表示される"セル参照"のウィンドウの「<=」の記号の右の▼をクリックし、「データ」を選ぶ。 「制約条件の追加」ダイアログボックスの"制約条件"に、「バイナリ」が自動的に入ります。 「追加」ボタンを押し、次に「キャンセル｣ボタンを押します。 「ソルバー：パラメータ設定」ダイアログボックスの実行ボタンを押します。 参考に実施してみてください。XPでしたらデータ数は20個まででお願いします。
(atiboh)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.