Q&A
回答ありがとうございます。
頂いたコードがどんな意味なのか、まだ理解できませんが、
時間をかけて解析してみたいと思います。
###前提・実現したいこと
EXCELのセルA1からA20まで整数が入っています。
これらの整数は小さい順にソートしてあります。
数値の重複もありえます。
セルB1に整数があります。
A列20個の整数を2個～20個足して、合計がセルB1
と一致する組み合わせを、全てC列以降に列挙したいのです。
2個・3個の組み合わせならば、For－Nextを個数分ネストさせて
自分でもできるのですが、20個の組み合わせは、For－Nextを
20回ネストさせることになり、気が遠くなります。
いい方法は無いでしょうか。
回答5件
0
考え方だけ。
要素が昇順に並んでいることを利用すると足切りができます。
たとえば目標（合計）値が20で、現在までの積算値が13の場合、次の要素値が8以上ならそれ以上探す必要はありません。（どれを足しても超える）
さらに、各要素における「自身から最終要素までの積算値」を事前に求めておくことにより、最大値での足切りもできます。
上記の例で、次の要素における「自身から最終要素までの積算値」が7未満ならそれ以上探す必要はありません。（全部足しても足りない）
投稿2017/02/15 01:05
総合スコア38266
0
ベストアンサー
A1～A20の数値は重複して加算することがないなら加える行を1加えない行を0と表すことにして20bitの全ての組み合わせの中から1のビットを2つ以上含みかつ対応するビットの数値を累積したものが目的の数に一致するかどうか検査するといった方法もあると思います。
要は何に対するループとするか工夫します。
効率をあまり考えずに実装してみると以下のような感じになりました。無駄な組み合わせを多数試すので効率がよくないです。
他にもっと効率がよく洗練された方法があると思います。
Sub te() Dim mask As Long Dim mask1 As Long Dim bit As Long Dim colIdx As Integer colIdx = 3 For mask = 3 To &HFFFFF bitCount = 0 bit = 1 mask1 = 0 v = Cells(1, 2) rowidx = 1 Do While mask > mask1 If mask And bit Then bitCount = bitCount + 1 mask1 = mask1 + bit v = v - Cells(rowidx, 1) If v < 0 Then Exit Do End If rowidx = rowidx + 1 bit = bit + bit Loop If v = 0 And bitCount >= 2 Then AddResult mask, colIdx colIdx = colIdx + 1 End If Next mask End Sub ' A列の値のうちmask内のビットが1のものを加算した結果が合計になっている。 ' 結果をcolIdx列へ記録する Sub AddResult(mask As Long, colIdx As Integer) Dim bit As Long bit = 1 rowA = 1 rowR = 1 For i = 1 To 20 If mask And bit Then Cells(rowR, colIdx) = Cells(rowA, 1) rowR = rowR + 1 End If bit = bit + bit rowA = rowA + 1 Next i End Sub
投稿2017/02/14 08:24
編集2017/02/14 08:26
総合スコア18394
0
面白そうなのでチャレンジしてみました。
他の回答にもありますが、要は全パターンの組み合わせのロジックをどのように作り込むかですね。
ビットで処理すると汎用性に欠けそうなので、配列で処理しています。
あとは再帰呼び出しでしょうか。
ベストアンサーが決まってしまいましたが、時間ができたので解説しておきます。
他の方のビットを使った処理では、使用する数字の数に限界（32ビットなので32個まで）があるのと、処理のわかりやすさから、次のような配列を用意して処理しています。
例
A1=1
A2=2
A3=3
～
nums(0,0)=1 nums(1,0)=0
nums(0,1)=2 nums(1,1)=0
nums(0,2)=3 nums(1,2)=0
～
2次元目は必ず0です。
idx配列は、2次元目が0か1のどちらを指すかを管理します。
このようにして、idx配列が0と1の全組み合わせを生成します。
idx(0)=0,idx(1)=1,idx(2)=0
であるなら、
nums(0,0)=1,nums(1,1)=0,nums(0,2)=2
を参照することになります。
numsとidxを使い合計値を算出し、C1と一致すれば式を出力という処理になっています。
VBA
1Const MAX = 19 2Dim idx(MAX) As Integer 3Dim nums(1, MAX) As Integer 4 5Sub test() 6 7 Dim y As Integer 8 Dim r As Integer 9 Dim total As Integer 10 11 ' インデックスとデータを初期化 12 For y = 0 To MAX 13 idx(y) = 0 14 nums(0, y) = Cells(y + 1, 1).Value 15 nums(1, y) = 0 16 Next 17 18 ' 全パターン組み合わせ出力 19 r = 1 20 Do 21 ' 合計値を計算 22 total = 0 23 For y = 0 To MAX 24 total = total + nums(idx(y), y) 25 Next 26 27 ' 合計値が一致した場合、結果を出力 28 If total = Cells(1, 2).Value Then 29 Call OutResult(r) 30 r = r + 1 31 End If 32 33 ' 次の組み合わせ生成 34 If SetNext(MAX) Then Exit Do 35 Loop 36 37End Sub 38 39Function SetNext(pos As Integer) As Boolean 40 41 SetNext = True 42 43 If pos < 0 Then Exit Function 44 45 idx(pos) = idx(pos) + 1 46 47 If idx(pos) > 1 Then 48 idx(pos) = 0 49 If pos <> 0 Then 50 SetNext = SetNext(pos - 1) 51 Exit Function 52 Else 53 SetNext = True 54 Exit Function 55 End If 56 End If 57 58 SetNext = False 59 60End Function 61 62Sub OutResult(r As Integer) 63 64 Dim y As Integer 65 Dim result As String 66 67 result = "'" 68 For y = 0 To 19 69 If idx(y) = 0 Then 70 If result <> "'" Then 71 result = result & "+" 72 End If 73 result = result & nums(0, y) 74 End If 75 Next 76 Cells(r, 3).Value = result 77 78End Sub
投稿2017/02/15 00:46
編集2017/02/20 01:46
総合スコア16998
0
20個の中からn個を取り出す組み合わせは1,048,575通りあります。
2個以上を取り出す組み合わせという条件があるので、0個を取り出す組み合わせ(1個)と、1個を取り出す組み合わせ(20個)の計21個は減りますが、元の数に対して誤差に過ぎないほど小さい数字です。
これらのパターンを全てチェックし、目的の値と一致するものを取り出すということになりますので、相当に重い処理だということはご承知おきください。
方法はいくつかあると思いますが、コーディングがシンプルなものとして２進数で加算判断する方法があります。
処理手順としては以下のような流れになります。
①全パターンをループ処理
②ループ回数を２進数で表したときに１が立っている桁の行を加算
③②の加算結果がB1セルと一致していればC列に出力
２進数を利用する
②の部分が分かりずらいと思いますので、少し掘り下げて説明します。
※20個ではサンプルとして多すぎるので、この説明ではA1～A5の５個の中からn個を取り出すものとして説明します。
５個の中からｎ個を取り出すパターン数は2^5 = 32パターンあります。
各セルから値を取り出す場合を１、取り出さない場合を０とした場合、
No A1 A2 A3 A4 A5 ----------------- 00 0 0 0 0 0 01 0 0 0 0 1 02 0 0 0 1 0 03 0 0 0 1 1 04 0 0 1 0 0 05 0 0 1 0 1 06 0 0 1 1 0 07 0 0 1 1 1 08 0 1 0 0 0 09 0 1 0 0 1 10 0 1 0 1 0 11 0 1 0 1 1 12 0 1 1 0 0 13 0 1 1 0 1 14 0 1 1 1 0 15 0 1 1 1 1 16 1 0 0 0 0 17 1 0 0 0 1 18 1 0 0 1 0 19 1 0 0 1 1 20 1 0 1 0 0 21 1 0 1 0 1 22 1 0 1 1 0 23 1 0 1 1 1 24 1 1 0 0 0 25 1 1 0 0 1 26 1 1 0 1 0 27 1 1 0 1 1 28 1 1 1 0 0 29 1 1 1 0 1 30 1 1 1 1 0 31 1 1 1 1 1
の32パターンとなります。
ここで開始番号を00としたのにはちょっと意味があります。
（２進数をご存知であれば説明不要かもしれませんが）00～31という10進数の数値を２進数で表したものが
0 は 00000
1 は 00001
10 は 01010
31 は 11111
となるのです。
つまり0～31をループして２進数としたときに各桁が１かどうかをチェックして、1が立っている桁に対応するセルだけを加算してあげる。
これを全32パターン分繰り返せば全パターンが網羅できるというわけです。
ビット演算について
各桁に1が立っているかどうか？の判断はビット演算という手法を用います。
(検査する値) And 2^(調べたい桁-1)という判定で、各桁が1か0かが判断できます。
ここを細かく説明すると結構なボリュームになってしまいますのでここでは割愛しますが、詳しくは「ビット演算」などで調べてみてください。
例を挙げると、10は2進数で01010です。
1桁目(一番右)は0ですので、(10) And (2^(1-1)) はFalseとなります。
2桁目(右から2番目)は1ですので、(10) And (2^(2-1)) はTrueとなります。
この判定により、１・３・５の場合はFalseとなるのでA1・A3・A5セルは加算せず、Trueとなる２・４の場合だけA2・A4セルだけ加算するようにします。
ビット演算は難しいので、最初はわかりにくいと思います。
例えば 31 は 11111ですが、これは (2^4 + 2^3 + 2^2 + 2^1 + 2^0 = 16 + 8 + 4 + 2 + 1 = 31)だから5桁全てに1が立っている、ということなのです。
同様に 10 は 01010ですが、これは ( 2^3 + 2^1 = 0 + 8 + 0 + 2 + 0 = 10)だから2桁目と4桁目が1なのです。
自分はここらへんが理解できるまでビット演算が大嫌いでした。。今でも好きなものではありませんが(^-^;
これらを踏まえてプログラムにすると
Const iMax As Integer = 20 '組み合わせ候補数 'メイン処理 Sub test() Dim lLoop As Double 'ループカウンタ Dim lRow As Long '結果出力行 lRow = 1 '組み合わせ候補数の桁数の2進数全パターンをループ処理(2のiMax乗) For lLoop = 0 To (2 ^ iMax) - 1 If (2 ^ iMax) - lLoop - 1 Mod 10000 = 0 Then Cells(25, "A") = (2 ^ iMax) - lLoop - 1 DoEvents End If '２進数文字列の中に"1"が2個以上存在する場合だけ計算する Dim lAns As Long '結果値 Dim strShiki As String '結果式 '計算処理 lAns = fncCalc(lLoop, strShiki) '有効な式があり、計算結果がB1セルとなる If strShiki <> "" And lAns = Cells(1, "B").Value Then '計算結果をC列に出力 Cells(lRow, "C") = lAns Cells(lRow, "D") = strShiki '出力行をインクリメント lRow = lRow + 1 End If '(参考情報：2進数文字列を出力) ※Dec2Binが9桁までしか対応していないため。 If iMax < 9 Then '表示用２進数文字列の作成 Dim strBIN As String strBIN = Right(String(iMax, "0") & WorksheetFunction.Dec2Bin(lLoop), iMax) 'D列に2進数文字列を出力 Cells(lLoop + 1, "D") = strBIN If strShiki <> "" Then '計算式をE列に出力 Cells(lLoop + 1, "E") = strShiki Cells(lLoop + 1, "F") = lAns End If End If Next MsgBox "Finish" End Sub '計算処理 Function fncCalc(vdNumber As Double, vsShiki As String) As Long Dim lAns As Long Dim iLoop As Integer Dim blnAddFlg As Boolean lAns = 0 vsShiki = "" blnAddFlg = False '2進数の桁数分ループ For iLoop = 0 To iMax - 1 '2進数として各桁をチェック If vdNumber And 2 ^ iLoop Then '"1"の場合、対象行の値を加算 lAns = lAns + Cells(iLoop + 1, "A").Value '参考情報として式も作成 If vsShiki <> "" Then '加算 vsShiki = vsShiki & " + " blnAddFlg = True End If vsShiki = vsShiki & Cells(iLoop + 1, "A").Value End If Next '加算していない場合、0個or１個のみの組み合わせ If blnAddFlg = False Then '出力対象外のため式なしとする vsShiki = "" End If fncCalc = lAns End Function
私の投稿より前に、同じくビット演算での回答がKSwordOfHasteさんからされていました。
内容かぶってしまいましたが、一応わかりにくいですが解説も記載しているので投稿させていただきます。
参考になれば幸いです。
投稿2017/02/14 12:59
編集2017/02/20 00:33
総合スコア3013
回答ありがとうございます。
頂いたコードですが、うまく動きませんでした。
ソース公開用に手直しした部分がエラーになっていました。
・プロシージャ外での変数への値代入 ⇒ メインプロシージャ内で代入する、または定数とすることで解消。
・strBIN変数の2重宣言 ⇒ 余分な宣言を除去することで解消。
大変失礼しましたm(__)m
ただ、そのままで動かないからといってあきらめてしまうほどの難しい問題でもなかったようなので、動くところまで少しがんばって手直ししてみていただきたかったです(T-T)
---
今回の質問では、組み合わせのパターンを網羅する（または不要なパターンをうまく除外する）ためのプログラムの仕組みが焦点になっていたと思います。
そのアプローチとしてTTyp03さんのように汎用性をあげるために正攻法で配列を使う方法や、私やKSwordOfHasteさんのようにパターン判定ロジックを簡潔にするために２進法を使う方法などが提示されました。
それぞれメリッド・デメリットもあるのですが、まずはそれぞれがどんな形でパターン網羅しているのか理解することが第一です。
それができると、can110さん提示の考え方を盛り込んだり、より無駄を省いて高速化する方法なども見えてくるかもしれません。
時間が掛かっても理解しようという姿勢が素晴らしいと思いますので、ぜひがんばってみてください。
0
投稿2017/02/14 08:14
総合スコア801
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2017/02/19 05:56