質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.53%

  • VBA

    2259questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

合計がNになる数値の組み合わせを全て列挙したい

解決済

回答 5

投稿

  • 評価
  • クリップ 0
  • VIEW 7,718

garucia

score 1

前提・実現したいこと

EXCELのセルA1からA20まで整数が入っています。
これらの整数は小さい順にソートしてあります。
数値の重複もありえます。

セルB1に整数があります。
A列20個の整数を2個~20個足して、合計がセルB1
と一致する組み合わせを、全てC列以降に列挙したいのです。

2個・3個の組み合わせならば、For-Nextを個数分ネストさせて
自分でもできるのですが、20個の組み合わせは、For-Nextを
20回ネストさせることになり、気が遠くなります。

いい方法は無いでしょうか。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 5

checkベストアンサー

+1

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/19 15:25

    回答ありがとうございます。
    頂いたコードがどんな意味なのか、まだ理解できませんが、
    時間をかけて解析してみたいと思います。

    キャンセル

+1

考え方だけ。

要素が昇順に並んでいることを利用すると足切りができます。

たとえば目標(合計)値が20で、現在までの積算値が13の場合、次の要素値が8以上ならそれ以上探す必要はありません。(どれを足しても超える)

さらに、各要素における「自身から最終要素までの積算値」を事前に求めておくことにより、最大値での足切りもできます。
上記の例で、次の要素における「自身から最終要素までの積算値」が7未満ならそれ以上探す必要はありません。(全部足しても足りない)

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/02/19 14:56

    参考にさせていただきます。
    ありがとうございました。

    キャンセル

0

これはどっちかというとアルゴリズムの問題ですね。
少し考えてみたんですが、答えはでずぐぐってみました。

「合計組み合わせアルゴリズム」

リンク内容1
リンク内容2

上記リンクを参照してください。
回答が載ってあるかと。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/02/19 15:00

    参考にさせていただきます。
    ありがとうございました。

    キャンセル

0

20個の中からn個を取り出す組み合わせは1,048,575通りあります。

2個以上を取り出す組み合わせという条件があるので、0個を取り出す組み合わせ(1個)と、1個を取り出す組み合わせ(20個)の計21個は減りますが、元の数に対して誤差に過ぎないほど小さい数字です。

これらのパターンを全てチェックし、目的の値と一致するものを取り出すということになりますので、相当に重い処理だということはご承知おきください。


方法はいくつかあると思いますが、コーディングがシンプルなものとして2進数で加算判断する方法があります。

処理手順としては以下のような流れになります。
①全パターンをループ処理
②ループ回数を2進数で表したときに1が立っている桁の行を加算
③②の加算結果がB1セルと一致していればC列に出力

2進数を利用する

②の部分が分かりずらいと思いますので、少し掘り下げて説明します。

※20個ではサンプルとして多すぎるので、この説明ではA1~A5の5個の中からn個を取り出すものとして説明します。

5個の中からn個を取り出すパターン数は2^5 = 32パターンあります。
各セルから値を取り出す場合を1、取り出さない場合を0とした場合、

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としたのにはちょっと意味があります。
(2進数をご存知であれば説明不要かもしれませんが)00~31という10進数の数値を2進数で表したものが
0 は 00000 
1 は 00001 
10 は 01010 
31 は 11111 
となるのです。

つまり0~31をループして2進数としたときに各桁が1かどうかをチェックして、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となります。
この判定により、1・3・5の場合はFalseとなるのでA1・A3・A5セルは加算せず、Trueとなる2・4の場合だけ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

        '2進数文字列の中に"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
            '表示用2進数文字列の作成
            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個or1個のみの組み合わせ
    If blnAddFlg = False Then
        '出力対象外のため式なしとする
        vsShiki = ""
    End If

    fncCalc = lAns

End Function

私の投稿より前に、同じくビット演算での回答がKSwordOfHasteさんからされていました。
内容かぶってしまいましたが、一応わかりにくいですが解説も記載しているので投稿させていただきます。

参考になれば幸いです。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/02/19 15:30

    回答ありがとうございます。
    頂いたコードですが、うまく動きませんでした。

    キャンセル

  • 2017/02/20 10:00

    ソース公開用に手直しした部分がエラーになっていました。
    ・プロシージャ外での変数への値代入 ⇒ メインプロシージャ内で代入する、または定数とすることで解消。
    ・strBIN変数の2重宣言 ⇒ 余分な宣言を除去することで解消。

    大変失礼しましたm(__)m

    ただ、そのままで動かないからといってあきらめてしまうほどの難しい問題でもなかったようなので、動くところまで少しがんばって手直ししてみていただきたかったです(T-T)

    ---
    今回の質問では、組み合わせのパターンを網羅する(または不要なパターンをうまく除外する)ためのプログラムの仕組みが焦点になっていたと思います。

    そのアプローチとしてTTyp03さんのように汎用性をあげるために正攻法で配列を使う方法や、私やKSwordOfHasteさんのようにパターン判定ロジックを簡潔にするために2進法を使う方法などが提示されました。
    それぞれメリッド・デメリットもあるのですが、まずはそれぞれがどんな形でパターン網羅しているのか理解することが第一です。

    それができると、can110さん提示の考え方を盛り込んだり、より無駄を省いて高速化する方法なども見えてくるかもしれません。

    時間が掛かっても理解しようという姿勢が素晴らしいと思いますので、ぜひがんばってみてください。

    キャンセル

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と一致すれば式を出力という処理になっています。

Const MAX = 19
Dim idx(MAX) As Integer
Dim nums(1, MAX) As Integer

Sub test()

    Dim y As Integer
    Dim r As Integer
    Dim total As Integer

    ' インデックスとデータを初期化
    For y = 0 To MAX
        idx(y) = 0
        nums(0, y) = Cells(y + 1, 1).Value
        nums(1, y) = 0
    Next

    ' 全パターン組み合わせ出力
    r = 1
    Do
        ' 合計値を計算
        total = 0
        For y = 0 To MAX
            total = total + nums(idx(y), y)
        Next

        ' 合計値が一致した場合、結果を出力
        If total = Cells(1, 2).Value Then
            Call OutResult(r)
            r = r + 1
        End If

        ' 次の組み合わせ生成
        If SetNext(MAX) Then Exit Do
    Loop

End Sub

Function SetNext(pos As Integer) As Boolean

    SetNext = True

    If pos < 0 Then Exit Function

    idx(pos) = idx(pos) + 1

    If idx(pos) > 1 Then
        idx(pos) = 0
        If pos <> 0 Then
            SetNext = SetNext(pos - 1)
            Exit Function
        Else
            SetNext = True
            Exit Function
        End If
    End If

    SetNext = False

End Function

Sub OutResult(r As Integer)

    Dim y As Integer
    Dim result As String

    result = "'"
    For y = 0 To 19
        If idx(y) = 0 Then
            If result <> "'" Then
                result = result & "+"
            End If
            result = result & nums(0, y)
        End If
    Next
    Cells(r, 3).Value = result

End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/02/19 15:03

    ありがとうございました。
    どんなロジックなのか、まだよく理解できませんが、
    時間をかけて勉強したいと思います。

    キャンセル

同じタグがついた質問を見る

  • VBA

    2259questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。