プロが教える店舗&オフィスのセキュリティ対策術

いくつかの数字が並んでいて、その中から選んで足し算をします。
その足し算の答えがある範囲内に当てはまるような組み合わせを全部求めたいと思います。

分かりにくいので具体例を書きます。
0.5
1.1
1.8
2.3
3.8
4.2

上記の6個の数字からいくつか選んで足した結果が4.9~5.9になる組み合わせをすべて求めたいです。
この場合、
0.5+1.1+1.8+2.3=5.7
1.1+1.8+2.3=5.2
4.2+0.5=4.7
4.2+1.1=5.3
4.2+1.1+0.5=5.8
3.8+1.8=5.6
3.8+1.1=4.9
3.8+1.1+0.5=5.4
の8種類(もっとあったらごめんなさい)になると思います。
この8種類を書き出したいのですが、うまい方法が思い浮かびません。

ソルバーとかなのかと思って調べてみたのですが、計算式が確定していない場合は使えないみたいです。
やっぱりVBAを使わないと難しいでしょうか?

なんとか簡単にできる方法があれば、アドバイス下さい。
よろしくお願いいたします。

A 回答 (4件)

>上記の6個の数字からいくつか選んで足した結果が4.9~5.9になる組み合わせをすべて求めたいです。



なら、
4.2+0.5=4.7
これは、範囲外だよね!!

組合せの最適化をすれば、もっと速いコードもありそうですが・・・。
新規ブックの標準モジュール(Module1)に
'========================================================
Sub main()
 Dim 組合せセル範囲 As Range
 Dim 抜き取り数 As Long
 Dim asum As Double
 Dim 合計1 As Double
 Dim 合計2 As Double
 Dim d_rw As Long
 Range("a1:a6").Value = [{0.5;1.1;1.8;2.3;3.8;4.2}]
 MsgBox "サンプルデータをA列に設定"

 合計1 = 4.9
 合計2 = 5.9
 
 d_rw = 1
 Set 組合せセル範囲 = Range("a1", Cells(Rows.Count, "a").End(xlUp))
 組合せセル範囲.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
 For 抜き取り数 = 1 To 組合せセル範囲.Count
   Call init_comb(組合せセル範囲, 抜き取り数)
   ReDim ans(1 To 抜き取り数)
   Do While get_comb(ans()) = 0
    asum = Application.Sum(ans())
    If asum >= 合計1 And asum <= 合計2 Then
      Range(Cells(d_rw, 3), Cells(d_rw, 抜き取り数 + 2)).Value = ans()
      d_rw = d_rw + 1
    ElseIf asum > 合計2 Then
      skip_comb
      End If
    Loop
   Next
 MsgBox "以上、" & d_rw - 1 & " 通り検出しました"
End Sub



別の標準モジュールに(Module2)に
組合せリスト作成ルーチン
'===========================================================
Option Explicit
  Private c_svn As Long '抜き取り数保存
  Private c_myarray() '組合せ対象値の配列
  Private c_idx() As Long '配列のカレントポインタ
  Private cs_x() As Long '配列の基盤ポインタ
'=======================================
Function init_comb(rng As Range, seln As Long) As Double
  Dim i As Long
  Dim crng As Range
  c_svn = seln
  Erase c_myarray()
  Erase c_idx()
  Erase cs_x()
  i = 1
  ReDim Preserve c_myarray(1 To rng.Count)
  For Each crng In rng
   c_myarray(i) = crng.Value
   i = i + 1
   Next
  ReDim cs_x(1 To seln)
  ReDim c_idx(1 To seln)
  For i = 1 To UBound(c_idx())
   cs_x(i) = i
   c_idx(i) = i
   Next
  c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
  init_comb = WorksheetFunction.Combin(rng.Count, seln)
End Function
'=======================================
Function get_comb(ans()) As Long
  Dim i As Long
  Dim j As Long
  get_comb = 1
  For i = UBound(c_idx()) To LBound(c_idx()) Step -1
   If c_idx(i) + 1 <= UBound(c_myarray()) - c_svn + i Then
     c_idx(i) = c_idx(i) + 1
     get_comb = 0
     Exit For
   Else
     c_idx(i) = cs_x(i) + 1
     cs_x(i) = cs_x(i) + 1
     For j = i + 1 To UBound(cs_x())
      cs_x(j) = cs_x(j - 1) + 1
      c_idx(j) = cs_x(j)
      Next j
     End If
   Next
  If get_comb = 0 Then
   For i = LBound(c_idx()) To UBound(c_idx())
     ans(i) = c_myarray(c_idx(i))
     Next
   End If
End Function
'=======================================
Function skip_comb()
  Dim i As Long
  For i = UBound(c_idx()) To LBound(c_idx()) + 1 Step -1
   If c_idx(i) <> c_idx(i - 1) + 1 Then
     c_idx(i) = UBound(c_myarray()) - c_svn + i
     Exit For
     End If
   c_idx(i) = UBound(c_myarray()) - c_svn + i
   Next
End Function
'=======================================
Sub close_comb()
  Erase c_myarray()
  Erase c_idx()
  Erase cs_x()
End Sub

として、適当なシート(何も入力されていない)でmainを
実行してみてください。セルC1から条件にあった組合せを
表示します。
    • good
    • 0
この回答へのお礼

ありがとうございますー(T-T)
おっしゃるとおり、4.7は範囲外でした(^-^;

lark_0925様にいただいたコードを使ってみたら、理想通りの結果を得ることができました!
総当たりで足し算をしたとしても、その足している数字が何なのかを全部書き出すにはどうすれば…と思っていましたが、配列を利用すれば良かったのですね!
配列はなかなか難しくて、自分では使いこなせないのですが、lark_0925様のコードを見てなんとか理解しようと思います。

個人的には「Application.Sum(ans())」で合計を取れるということに感動しました!

それにしてもすごいですね!!!
こんなすぐにコードをかけてしまうなんて、尊敬です。
本当にとてもとても助かりました。
涙が出るほど嬉しいです。本当にありがとうございました。

お礼日時:2008/01/09 10:43

数個なら。

。。

A列にデータがあって、作業列が X~Z列だとして、
   X   Y   Z
1          001010
2 000001  4.2  010001
3 000010  3.8  010010
4 000011  8   011100
5 000100  2.3  110001
6 000101  6.5  110010
7 000110  6.1  111100

X2=TEXT(DEC2BIN(ROW(A1)),REPT("0",6))
X64までコピー(64=2^6)。
Y2=SUMPRODUCT($A$1:$A$6,MID(X2,ROW($A$1:$A$6),1)*1)
Y64までコピー。

Y列にオートフィルターで [4.9以上]AND[5.9以下] の条件で抽出。
抽出されたX列のデータをコピー、Z1に[形式を選択して貼り付け]-[値]。

  A   B  C  ・・・
1 0.5  0  0
2 1.1  0  1
3 1.8  1  0
4 2.3  0  0
5 3.8  1  0
6 4.2  0  1
7    5.6  5.3

B1=MID(INDEX($Z:$Z,COLUMN(A1)),ROW(A1),1)*1
B6までと、右へコピー。
B7=SUMPRODUCT($A1:$A6,B1:B6)
右へコピー。

1と0 で、その数字を使う使わない の判定にします。7行目は確認用。
B列は 1.8 + 3.8 = 5.6
C列は 1.1 + 4.2 = 5.3
という意味です。


VBA でやるなら、2つ足す場合、3つ足す場合、4つ足す場合・・・
と、やると、遅くなると思います。
総当りはどんな方法でも限界があるでしょうけど。

'データは、A1セルから空白無く、複数あるとする
Sub SoAtari()
 '目標値
 Const a As Currency = 4.9 '以上
 Const z As Currency = 5.9 '以下

 Dim n As Integer 'データ数
 Dim arr0, arr1() As Currency
 Dim b As Long
 Dim i As Long, j As Long 'ループ用、使い回し
 Dim col As Integer '列番号

 With Range("a1")
  n = .End(xlDown).Row
  arr0 = .Resize(n).Value
  .CurrentRegion.Offset(, 1).ClearContents
 End With

 '全ての組み合わせの和を配列arr1にセット
 '全て計算する必要は無いので、改善の余地あり
 ReDim arr1(1 To 2 ^ n - 1)
 For i = 0 To n - 1
  b = 2 ^ i
  arr1(b) = CCur(arr0(i + 1, 1))
  For j = 1 To b - 1
   arr1(b + j) = arr1(b) + arr1(j)
  Next j
 Next i

 col = 2
 For i = 1 To 2 ^ n - 1
  '目標値の範囲ならシートへ書き込む
  If arr1(i) >= a And arr1(i) <= z Then
   For j = 0 To n - 1
    If i And 2 ^ j Then Cells(j + 1, col).Value = arr0(j + 1, 1)
   Next j
   Cells(n + 1, col).Value = CDbl(arr1(i))
   col = col + 1
  End If
 Next i

 Erase arr0, arr1
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます!
すごい!!関数でもできるんですね。
0と1を使って使うかどうかの判定をしたり、それを組み合わせで全通り表示する方法など、たぶん一生考えても思いつけそうにありません。
感動しました(T-T)
9個まではちゃんとできました!
10個からは2進数が表示されないみたいでエラーになってしまいました。

VBAの改善とは、上限を超えた場合は計算をしなくても良いということですよね。
でも、試しに動かしてみたら速度に問題なく計算できました!!
結果が一覧になっていてとても見やすかったです。
とてもとても勉強になりました。
やはり配列はちゃんと勉強すればとても役立つのだと思いました。
ありがとうございました!!大感謝です。

お礼日時:2008/01/09 11:11

追伸 A列のデータは、昇順に整列されているものとします。

    • good
    • 0
この回答へのお礼

了解しました。

お礼日時:2008/01/09 10:44

類似していると言えば、


http://okwave.jp/qa257719.html
でしょうか。
ただ固定された答えではなく範囲内に入る組み合わせとなると、
もっとやっかいになるように思います。

回答ではなく、すいません。
    • good
    • 0
この回答へのお礼

本当にやっかいで、私一人ではどうにも解けず、ここに相談してみました。
ご回答ありがとうございます(^-^)

お礼日時:2008/01/09 10:34

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!