【初心者】Excelで複数の数字の組み合わせを探す方法

Question

Excelで複数の数字を組み合わせて、一致する数字の合計を探す方法を教えていただけると嬉しいです。

1行に「一致させたい数字」と「組み合わせたい数字15個」が並んでいます。それがその下にも同様の形式で続きます。

A1 B1 C1 D1 E1 F1 G1 H1……O1
90 20 30 15 24 5 15 70 ……56
→A1 の90になる組み合わせをB1〜O1から探す、
続いてA2になる組み合わせをB2〜O2から探す、という形で下に続きます。
※数字は何個組み合わせても良いですが、重複はできません。(C1の30×3等はできないです。)

結果表示は、できれば組み合わせた数字の色が変わる等「どれを組み合わせたか分かる状態」が希望です。
一致する組み合わせが複数あっても、1パターンが分かれば大丈夫です。

しかし、それによって処理がかなり重くなったり複雑になるようであれば、「組み合わせがあるかどうか」が表示されるようにしたいと考えています。

自分で調べた際にはソルバー、マクロ、関数を使う方法を見つけましたが、上手くいきませんでした。
1件ずつであればソルバーでできるのですが、数百〜数千件を行いたいため、まとめて処理ができる方法を探しています。
(ソルバーはこの方法で行いました。
https://www.google.co.jp/amp/s/amidagamine.com/notes/3729/amp
マクロも1件ずつ行う方法はネット上に色々あがっているものの知識が足りず、それを複数行で行うにはどうすれば良いのか分からない状態です)

純粋な組み合わせの数を考えてもかなり膨大な数になることは分かるのですが、可能な限り1度に多くの件数を探したいです。よろしくお願いいたします。

Comments

[sazi]

一体その計算をどの程度で行いたいのですか？
15個の数字の組み合わせでも3万2千個程度ありますから、1回の計算を十ミリ秒で行ったとしても300秒以上掛かる事になりますよね。
「組み合わせがあるかどうか」で行ったとしても、最長で掛かる時間は同じですし。

[yamaya0123]

1日の作業時間(放置可能時間)は5時間ほどです。期間は数年と言われると困りますが、数日、数ヶ月かかっても大丈夫です。どちらかというとかかる時間よりかかる手間を減らしたいのでできるだけまとめて作業→放置を繰り返したいです。
かかる時間を見て、厳しいようであれば件数は減らそうと思っています。
変な回答をしていたら申し訳ないです。

[sazi]

時間が掛かる場合は、24時間つけっ放しで放置できる専用のPCなどで行う想定ですか？
それはさておき、時間が掛かっても良いという事なら、この手の質問は自身でコードを作成して、時間を短縮したいという体の内容だと、色んな案の回答が付きやすいと思います。

[yamaya0123]

1日の5時間ごとに電源は消す必要があります。5時間の間全く触らず放置することは可能です。1日目1〜30行、2日目31〜60行というふうに、行数は適当ですが日ごとに区切って行いたいです。

[sazi]

ソルバーで1行分出来るなら、それをマクロ記録でマクロ化し、行数分繰り返すというのが思いつくところですね。

[yamaya0123]

すみません、先程のコメント後半の文章に今気がつきました。アドバイスありがとうございます。

お恥ずかしい話全くの初心者なもので、この作業を行うためだけに先週末から初心者向けの本を見ながらやってみてはいるものの、本と調べたマクロを見比べてどこから手をつけたら良いのかも分からない状態です。
このまま回答がつかないようでしたらもう少し自力で勉強してみて教えていただいたとおり質問をし直してみようと思います。
ご丁寧にありがとうございます。書いていただいた方法で調べてみます。

[ikadzuchi]

>saziさん
ちょっと時間の見積もりに疑問があったので試しにJavaScriptで計算してみましたが、ナイーブに2^15×15×1000のループで計算して3秒ほどしか掛かりませんでした。
Excelのマクロには疎いのですが、さすがに100000倍掛かることは無いのではないかと思います。

Answer 1

ちょっと整理しきれないところがありますが、書いてみました。
該当する組み合わせに色がつくはずです。

Sub sample()
    Dim ws As Worksheet
    Set ws = Worksheets(1)
    
    Dim ws2 As Worksheet
    Set ws2 = Worksheets.Add(, ws)
    ws2.Range("B1").Formula2 = "=1*MID(HEX2BIN(LEFT(DEC2HEX(ROW(B1:B16383),4),2),6)&HEX2BIN(RIGHT(DEC2HEX(ROW(B1:B16383),4),2),8),COLUMN(B1:O1)-1,1)"
    ws2.UsedRange.Value = ws2.UsedRange.Value
    
    Dim i, j, v, r, arr
    With WorksheetFunction
        For i = 1 To ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            v = ws.Range("A" & i).Value
            ws2.Range("A1:A16383").Formula = "=SUMPRODUCT(B1:O1," & ws.Range("B" & i & ":O" & i).Address(, , , True) & ")"
            If .CountIf(ws2.Range("A1:A16383"), v) > 0 Then
                r = .Match(v, ws2.Range("A1:A16383"), 0)
                For j = 2 To 14
                    If ws2.Cells(r, j) = 1 Then ws.Cells(i, j).Interior.Color = vbYellow
                Next
            End If
            DoEvents
        Next
    End With
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
    ws.Activate
End Sub

Answer 2

B列から順番にC列→Ｄ列...→O列まで各列の値を使用した場合と使用しなかった場合で、それぞれ解があるかを総当たりして、解があるかを算出します。
この場合、B列からO列まで最大14階層のLOOPになるので、そこは再帰関数の呼び出しという手法を用いて計算します。
詳しくはCalc2()関数のコメントを参照してください。
標準モジュールに以下のコードを入力してください。

'Const MAX = 14
Public Function Calc(ByVal sum As Long, ByRef objRange As Range) As Long
    Dim MAX As Long
    MAX = objRange.Columns.Count
    ReDim Values(1 To MAX) As Long  'B列からO列の値を格納する
    Dim i As Long
    For i = 1 To MAX
        Values(i) = objRange.Cells(1, MAX + 1 - i)  'O列をindexの1、B列を14とする
    Next
    Calc = Calc2(MAX, sum, Values())
End Function

'*****************************************************************************
'[引数] i:右から何番目の列かを示す
'       sum:iの右隣の列から右端列までの合計をいくつにしたいかの値を示す
'       Values():B列からO列の値の配列
'[戻値] B列からO列のうち計算に使用した列を14桁の2進数で示す(解が存在しない時は0とする)
'*****************************************************************************
Private Function Calc2(ByVal i As Long, ByVal sum As Long, ByRef Values() As Long) As Long
    'マイナスの時は、解なし
    If sum <= 0 Then
        Exit Function
    End If
    
    If sum = Values(i) Then
        'i列の値が、計算したい合計と等しい時は、該当列にbitを立てる
        Calc2 = 2 ^ (i - 1)
        'これより右の列の値は使用しないので計算を打ち切る
        Exit Function
    End If
    
    '一番右端の列の時は、計算終了
    If i = 1 Then
        Exit Function
    End If
    
    Dim Result As Long
    
    'i列目を使用すると仮定して右隣の列から右端の列まで解があるか試行する
    Result = Calc2(i - 1, sum - Values(i), Values())
    If Result <> 0 Then
        '自らの列の位置の2進数にbitを立てる
        Calc2 = Result + 2 ^ (i - 1)
        Exit Function
    End If
    
    'i列目を使用すると仮定したら解がなかったので、今度は不使用と仮定して、右隣の列から右端の列まで解があるか試行する
    Result = Calc2(i - 1, sum, Values())
    If Result <> 0 Then
        Calc2 = Result
        Exit Function
    End If
    
    '解なし
End Function

P列にセル関数=Calc(A1,B1:O1)を入力して下さい
Q列にセル関数=DEC2HEX(P1,4)を入力して下さい
R列にセル関数=HEX2BIN(LEFT(Q1,2),6) & HEX2BIN(RIGHT(Q1,2),8)を入力して下さい
そうするとR列に11110001000000のような14桁の2進数が表示されます
解がない場合はALL0となります
2進数に1のbitが立っている列が、計算対象となった列になります。

後はB1セルに条件付き書式を設定し、条件に=MID($R1,COLUMN(A1),1)*1=1を設定し、必要な範囲に適用します。

ロジックや計算に誤りがあるかもしれませんので、くれぐれも良く検証して確認下さい。

また、非常に処理効率に興味があるので、何行でどれほどの処理時間となったか結果をお教え願います。