エクセル２０００で・・・

質問

例）
122　　5422　　6470　　89802　　542　　584

のような不規則の整数が任意の数あって、その数字の何個かを使って
合計が６５４８になる組み合わせはどれか？　

なんて答えを出す事は可能でしょうか？
これは例ですが通常２０～３０くらいの数の時もあります。
もちろんそんな時は答えも２通り以上ある場合も起こります。
そんな事が簡単に出来ると個人的にはすごく便利なんですが・・・
無理でしょうか？

回答No.2

nishi6 · ベストアンサー

少し時間がたちましたがまだ入り用ですか？

コードを書いてみました。（素人の解法です。理論的なことは調べていません）。　使い方は、
Sheet1のA1、A2、A3・・・の順に使う数値を入力します。小さい数値から昇順にします。
ソートのコードを書いてもいいんですが、長くなるので手で操作（ソート）してください。
B1に指定する合計値を入力します。　後は下のマクロを実行します。

最初は、30個の数値を使うと、100日くらいかかるスピードでしたが、今は１時間程度でしょう。
数十秒でできるようにしたコードもありますが、回答するには長いのでこちらにしておきます。
30個使用しても、求める合計値によって、数秒で答えが出る場合もあります。

処理例（使用数値の個数と処理の所要時間）
　　　11　0:00:01
　　　12　0:00:02
　　　13　0:00:03
　　　14　0:00:07
　　　15　0:00:06
　　　16　0:00:06
　　　17　0:00:08
　　　18　0:00:08
　　　19　0:00:08
　　　20　0:00:11
　　　21　0:00:15
　　　22　0:00:25
　　　23　0:00:42
　　　24　0:01:10
　　　25　0:02:15
　　　26　0:04:20
　　　27　0:08:49　このスピードなら30個で1時間強

コードは、答えがありそうな範囲を絞り、全ての組み合わせを網羅して計算しています。
（再帰はあっさりオーバーフローしてしまった）
組み合わせは2進数のビットを使い、ビットのある桁数以下はExcelのFindメソッドであらかじめ計算した数値を探しています。
この考えを進めて、実際は30個近辺でも高速化できます。
使用する数の個数が15個単位くらいで、計算スピードを上げる上で壁があるようです。45個位から別の方法が必要になりそうです。（素人の独り言です）
決定的な方法があるんだろうか？

Sheet1のコードウインドウに貼り付けます。コメントも最低限にしています。
ここから
↓
Const nn = 14
Dim Dt() As Double, Kosuu As Integer
Dim inpTTL As Double, wkTotal As Double
Dim oRow As Long
Dim sch1024 As Range
Dim fndCell As Range, fndRow As Long, fstAdr As String

Sub KumiAwase()
　　Range("C:D").ClearContents: Range("AA:AA").ClearContents
　　Range("C1") = "開始：" & Format(Now(), "hh:mm:ss")
　　Application.ScreenUpdating = False

　　inpTTL = Range("B1") '*** 指定した合計値 ***
　　Kosuu = Range("A1").End(xlDown).Row
　　'データを読み込む
　　oRow = 0
　　ReDim Dt(Kosuu)
　　Dim rw As Integer, rw2 As Integer, wTTL As Long, wMin As Long
　　　　wMin = Cells(1, 1)
　　　　For rw = 1 To Kosuu
　　　　　　Dt(rw) = Cells(rw, 1): wTTL = wTTL + Dt(rw)
　　　　　　If Dt(rw) < wMin Then wMin = Dt(rw)
　　　　Next
　　'nn個までの加算テーブル
　　For rw = 1 To 2 ^ (Application.Min(Kosuu, nn)) - 1
　　　　wkTotal = 0
　　　　For rw2 = 1 To Application.Min(Kosuu, nn)
　　　　　　wkTotal = wkTotal - ((rw And 2 ^ (rw2 - 1)) > 0) * Dt(rw2)
　　　　Next
　　　　Cells(rw, 27) = wkTotal
　　Next
　　Set sch1024 = Range("AA1:AA" & Range("AA1").End(xlDown).Row)

　　'ありえない指定数値は計算しない
　　If inpTTL < wMin Or wTTL < inpTTL Then
　　　　MsgBox "組み合せは存在しません！"
　　　　Exit Sub
　　End If

　　'上限・下限を計算する（明らかに解にならない組み合わせを排除する）
　　Dim ctLP As Long, chkSup As Double, chkInf As Double
　　'<上限計算>
　　　　wkTotal = inpTTL
　　　　For ctLP = Kosuu To 1 Step -1
　　　　　　If Dt(ctLP) < wkTotal Then
　　　　　　　　chkSup = chkSup + 2 ^ (ctLP - 1): wkTotal = wkTotal - Dt(ctLP)
　　　　　　End If
　　　　Next
　　'<下限計算>
　　　　wkTotal = inpTTL
　　　　For ctLP = 1 To Kosuu
　　　　　　If Dt(ctLP) < wkTotal Then
　　　　　　　　chkInf = chkInf + 2 ^ (ctLP - 1): wkTotal = wkTotal - Dt(ctLP)
　　　　　　End If
　　　　Next

　　'*** 計算開始！ ***
　　For ctLP = Int(chkInf / (2 ^ nn)) To Int(chkSup / (2 ^ nn))
　　　　Call KumiAwaseSub(ctLP)
　　Next

　　Range("AA:AA").ClearContents
　　Application.ScreenUpdating = True
　　Range("C2") = "終了：" & Format(Now(), "hh:mm:ss")
　　Range("C4") = "組み合せ：" & oRow & " 組"
　　MsgBox "終了"
End Sub

'*** 組み合せ ***
Private Sub KumiAwaseSub(ByVal vBit As Long)
　　Dim oTxt1 As String, oTxt2 As String, i As Integer

　　wkTotal = 0
　　For i = nn To Kosuu - 1 'ビットを調べる
　　　　If vBit And 2 ^ (i - nn) Then
　　　　　　wkTotal = wkTotal + Dt(i + 1)
　　　　End If
　　Next

　　Set fndCell = sch1024.Find(what:=(inpTTL - wkTotal), LookAt:=xlWhole)
　　If Not fndCell Is Nothing Then
　　　　oTxt1 = ""
　　　　For i = nn To Kosuu - 1
　　　　　　If vBit And 2 ^ (i - nn) Then
　　　　　　　　oTxt1 = oTxt1 & "+" & Dt(i + 1)
　　　　　　End If
　　　　Next
　　　　If oTxt1 <> "" Then oTxt1 = Right(oTxt1, Len(oTxt1) - 1)

　　　　fstAdr = fndCell.Address
　　　　Do
　　　　　　fndRow = fndCell.Row
　　　　　　oTxt2 = ""
　　　　　　For i = 1 To nn
　　　　　　　　If fndRow And 2 ^ (i - 1) Then
　　　　　　　　　　oTxt2 = oTxt2 & "+" & Dt(i)
　　　　　　　　End If
　　　　　　Next
　　　　　　oRow = oRow + 1
　　　　　　Range("D" & oRow) = oTxt1 & Right(oTxt2, Len(oTxt2) + (oTxt1 = "")) & " /"

　　　　　　Set fndCell = sch1024.FindNext(fndCell)
　　　　Loop While Not fndCell Is Nothing And fndCell.Address <> fstAdr
　　End If
End Sub

お礼

ありがとうございます。返事遅くなって申し訳ありません。
大変参考になりました。一度是非試してみます。

回答No.1

imogasi

回答ではありませんが、「感想」的に書いてみます。
もちろんコンピュターで解が求められるはずです。しかし通常のやりかたでは、30個の数字ともなれば
場合の数が多くなりすぎて、実行に時間がかかり、実質的には答えが出ないのと同じとなるでしょう。（私もこのような問題が解ければいいなと何かのケースで思ったことがあります。）そこで必要なのは良いアルゴリズムなんです。これは天才的な一部の人を除いて、数日間程度考えても良いものは生まれないでしょう。したがってその種の本を探して、アルゴリズムの良いのを探すことです。ただし
（私は少し数学に興味があって、本も読みましたが、）この問題についての、説明を見たことがありません。しかし世の中には良く知っておられる人もいるものです。このＯＫＷＥＢを見てくれていれば良いのですが。初歩的に解くには、数字を配列に入れ、２つ足す場合、３つ足す場合、４つ足す場合、・・・とたどり、足した和が６５４８になるかを繰り返すことになるでしょう。その時、数の大きさでソートしておき、数や和が６５４８を越えれば打ち切ることにより演算を少なくするとか考えつきますね。クイックソートのようなすばらしいアルゴリズムを本件につき誰か教えてほしいですね。