Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6882 / 13644 ツリー ←次へ | 前へ→

【42432】組合せ 教えてください 06/9/11(月) 23:32 質問[未読]
【42467】Re:組合せ [名前なし] 06/9/12(火) 21:05 発言[未読]
【42471】Re:組合せ 漂流民 06/9/13(水) 0:24 発言[未読]
【42472】Re:組合せ ナイスプログラム 06/9/13(水) 1:07 回答[未読]
【42473】Re:組合せ ichinose 06/9/13(水) 6:37 発言[未読]
【42529】Re:組合せ ナイスプログラム 06/9/13(水) 21:58 回答[未読]
【42556】Re:組合せ 教えてください 06/9/14(木) 23:04 お礼[未読]

【42432】組合せ
質問  教えてください  - 06/9/11(月) 23:32 -

引用なし
パスワード
     59
  45
  31
  11
  32

という5つの数字があるとします。この5つの数字を使って74になる組合せを
探したいときにどのようにすればよいのですか?(すべて足し算での組合せ。上の例では31と11と32を足したことが知りたいのです。)教えてください。ちなみに実際には30個ぐらいの数字からXになる組合せを見つけなければならないのです…。

【42467】Re:組合せ
発言  [名前なし]  - 06/9/12(火) 21:05 -

引用なし
パスワード
   >どのようにすればよいのですか?

まずは過去ログを検索しましょう。
このページの上のほうの・・・     
新規投稿┃ツリー表示┃一覧表示┃トピック表示┃検索┃設定┃過去ログ┃ホーム
                        ↑ここをクリック

組み合わせ 合計

というキーワードでヒットしました。
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=6113;id=excel

【42471】Re:組合せ
発言  漂流民  - 06/9/13(水) 0:24 -

引用なし
パスワード
   ▼教えてください さん:
>  59
>  45
>  31
>  11
>  32
>
>という5つの数字があるとします。この5つの数字を使って74になる組合せを
>探したいときにどのようにすればよいのですか?(すべて足し算での組合せ。上の例では31と11と32を足したことが知りたいのです。)教えてください。

ここまでの話であれば簡単に答えは出ます。

問題なのは
>ちなみに実際には30個ぐらいの数字からXになる組合せを見つけなければならないのです…。
こちらです。

少なくとも組み合わせる個数をある程度絞らないと大変な量ですよ。

教えてください さんの例で数字が5個なら

59 = 59
45 = 45
59 + 45 = 104
31 = 31
59 + 31 = 90
45 + 31 = 76
59 + 45 + 31 = 135
11 = 11
59 + 11 = 70
45 + 11 = 56
59 + 45 + 11 = 115
31 + 11 = 42
59 + 31 + 11 = 101
45 + 31 + 11 = 87
59 + 45 + 31 + 11 = 146
32 = 32
59 + 32 = 91
45 + 32 = 77
59 + 45 + 32 = 136
31 + 32 = 63
59 + 31 + 32 = 122
45 + 31 + 32 = 108
59 + 45 + 31 + 32 = 167
11 + 32 = 43
59 + 11 + 32 = 102
45 + 11 + 32 = 88
59 + 45 + 11 + 32 = 147
31 + 11 + 32 = 74       ←ヒット
59 + 31 + 11 + 32 = 133
45 + 31 + 11 + 32 = 119
59 + 45 + 31 + 11 + 32 = 178

の全31通りで簡単に出ます。(コードは下記)
この組み合わせの数は「=2^5-1」で求められます。
例えば数字が6個なら「=2^6-1」で63通り、
数字が10個なら「=2^10-1」で1,023通りです。
つまり組み合わせの数は数字が1つ増えるごとに倍になり、「2のn乗−1」となります。
で、これが30個になると「=2^30-1」で1,073,741,824通りとなります。
具体的に言うと「=(2^30)/65536/256」、シートを64枚フルで使うことになります。
>30個ぐらいの数字からXになる組合せを見つけなければならないのです…。
このままの条件だと、普通に考えて10億個以上の組み合わせが出てくることになりますよ^^

それと、処理時間の問題もあります。
私のショボイPCとコード(「(2のn乗−1)xn」回ループ)だと、
15個・・・6秒849
16個・・・12秒457
17個・・・27秒678
20個・・・4分9秒218
ほぼ理論通り倍になっていきます。
15個で約7秒とすると理論的には
「=7*(2^15)/60/60」で約64時間
最新の高速パソコンを使用しても丸1日はかかりそうです。
※高速化を図れる可能性は多分にありますが組み合わせが
 1,073,741,824通りあることには変わりません。
さらに、結果をどこかに格納する処理を加えることを考えると・・・

いずれにしても現実的ではないですね^^

参考までに、サンプルです。
A列に任意の数字を入れてテストしてください。
※最初は15行ぐらいまでで実行してください。
 それ以降は1行増えるごとに処理時間が約倍になると思ってください。

'*****************************************************************************************************
Sub test()
  Dim rend As Long, tmp As Long
  Dim i As Long, j As Long
  Dim res As String
  Const req As Long = 74

  rend = Range("A65536").End(xlUp).Row

  For i = 1 To 2 ^ rend - 1
    tmp = 0
    res = ""
    For j = 1 To rend
      If (i And 2 ^ (j - 1)) <> 0 Then
        tmp = tmp + Cells(j , 1).Value
        If res <> "" Then res = res & " + "
        res = res & Cells(j , 1).Value
      End If
    Next j
'    Debug.Print res & " = " & tmp
    If tmp <> req Then Debug.Print res
  Next i
End Sub

【42472】Re:組合せ
回答  ナイスプログラム WEB  - 06/9/13(水) 1:07 -

引用なし
パスワード
    今晩は。

 難しかったですが、何とか出来ました。バグがあるかも知れないので、テストして
下さい。

【使い方】
a列の上から下に掛けて組み合わせる数字を書く。
b1に合計する数を書く。(この場合74)。
下記コードを標準モジュールに書いて動かす。

【コード】

Option Explicit
Option Base 1

Dim sinki As Object
Dim ii() As Integer
Dim index As Integer, ic As Integer


Sub 合計()

ThisWorkbook.Worksheets(1).Copy
Set sinki = ActiveWorkbook

ReDim ii(Range("a65536").End(xlUp).Row)
ic = 3

index = 0
Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess

Call 計算(1, Range("b1").Value)

End Sub

Private Sub 計算(ByVal i1 As Integer, ans2 As Integer)

Dim i As Integer

Cells(i1, 1).Select


If i1 > UBound(ii) Then
  If ii(index) = UBound(ii) Then
    index = index - 1
    If index = 0 Then Exit Sub
  End If
    
  ii(index) = ii(index) + 1
  
  ans2 = Range("b1").Value
  For i = 1 To index
    ans2 = ans2 - Cells(ii(i), 1)
    
  Next

  Call 計算(ii(index) + 1, ans2)
Else

  ans2 = ans2 - Cells(i1, 1).Value
  Select Case ans2
    Case Is > 0
      index = index + 1
      ii(index) = i1
    
      Call 計算(i1 + 1, ans2)
    Case 0
      ic = ic + 1
      index = index + 1
      ii(index) = i1
      For i = 1 To index
        Cells(i, ic).Value = Cells(ii(i), 1).Value
      Next
    
      ans2 = ans2 + Cells(i1, 1).Value
      index = index - 1
      Call 計算(i1 + 1, ans2)
    Case Is < 0
      ans2 = ans2 + Cells(i1, 1).Value
      Call 計算(i1 + 1, ans2)
    End Select

End If

End Sub

【42473】Re:組合せ
発言  ichinose  - 06/9/13(水) 6:37 -

引用なし
パスワード
   みんさん、おはようございます。
同じような質問に過去にも投稿したことが何回かあります。
今までは、組合せリストが気の遠くなる数字でもVBAが絶え得うるコード
(例え2^30-1=1073741823で時間がかかってもメモリ不足を起こさない
 且つ、再利用しやすいインターフェース)
がこの手のご質問では私の目的でした。
(足し算の組合せを速く求める問題には、あまり興味がなかったのですが)

以前にも投稿したコードに少しコードを追加して

2^30-1通りのチェックの中でどれだけのリスト数のチェックを飛ばせるかで考えました。

標準モジュールに


'===============================================================
Sub main()
  Dim 組合せセル範囲 As Range
  Dim 抜き取り数 As Long
  Dim asum As Double
  Dim 合計 As Long
  Dim d_rw As Long
  合計 = 74 '求めたい合計値を指定
  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 = 合計 Then
      Range(Cells(d_rw, 3), Cells(d_rw, 抜き取り数 + 2)).Value = ans()
      d_rw = d_rw + 1
     ElseIf asum > 合計 Then
      Call skip_comb
      End If
     Loop
   Next
  MsgBox "以上、" & d_rw - 1 & " 通り検出しました"
End Sub


別の標準モジュールに
'=======================================
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


アクティブシートのセルA1からA2、A3・・・A30に例えば、

196
182
179
178
177
167
142
140
139
130
129
125
114
111
102
90
79
76
63
62
60
48
46
30
17
15
11
9
6
5

というデータがある場合、

mainを実行してみてください。

上記のコードでは、合計値が74になる数の組合せを同じシートの
セルC1から書き込みます。
(全てのリストを出力しますから、一つでよいならmainを変更してください)

セルに書き込んでいますからリストが65536を超えればエラーになりますが、
その時は出力場所を変えてください。

まっ、上記の例では、一瞬ですし、9通りの組合せがでています。
それでも全部のリストをチェックしなければならない事象の場合は時間がかかりますが・・。
試してみてください。

【42529】Re:組合せ
回答  ナイスプログラム WEB  - 06/9/13(水) 21:58 -

引用なし
パスワード
    今晩は。バグが有りました。

【問題点】
1.ソートするとrange("b1")の値が他に移動してしまう。
2.1を解決しても、シートの列が足らないので書ききれない。
3.2を解決しても、スタックが足りなくなる。

 これらの問題点を何とか解決しました。

【使い方】
前と同じ

【今後の課題】
本当に計算が合っているかどうか分らない。

【注意点】
まだバグがあるかもしれない。

*sub 記入()で使っているselectは、パソコンが動いていることを確認する
画面モニター用です。いらなければ削除してください。
*途中で止める時はCtrl + Pause

【コード】

Option Explicit
Option Base 1

Dim sinki As Object
Dim ii() As Integer
Dim index As Integer, total As Integer
Dim ir As Long, ic As Long


Sub 合計()

ThisWorkbook.Worksheets(1).Copy
Set sinki = ActiveWorkbook
total = Range("b1").Value

ReDim ii(Range("a65536").End(xlUp).Row)
ic = 4
ir = 1

Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess

計算2

End Sub

Private Sub 計算2()

Dim ans As Integer, i As Integer, j As Integer, rend As Integer
index = 0
i = 1
ans = total
rend = Range("a65536").End(xlUp).Row

Do
  Select Case Cells(i, 1).Value
    Case Is < ans
      index = index + 1
      ii(index) = i
      ans = ans - Cells(i, 1).Value
      
    Case ans
      index = index + 1
      ii(index) = i
      記入
      index = index - 1
      
  End Select
  i = i + 1
  
  If i > rend Then
    If ii(index) = rend Then
      Do While i > rend
        If index = 1 Then Exit Sub
        index = index - 1
        ii(index) = ii(index) + 1
        ans = total
        For j = 1 To index
          ans = ans - Cells(ii(j), 1).Value
        Next
        i = ii(index) + 1
      Loop
    Else
      ii(index) = ii(index) + 1
      If ii(index) = rend Then
        Do While i > rend
          If index = 1 Then Exit Sub
          index = index - 1
          ii(index) = ii(index) + 1
          ans = total
          For j = 1 To index
            ans = ans - Cells(ii(j), 1).Value
          Next
          i = ii(index) + 1
        Loop
      Else
        ans = total
        For j = 1 To index
          ans = ans - Cells(ii(j), 1).Value
        Next
        i = ii(index) + 1
      End If
    End If
  End If
      
Loop


End Sub


Private Sub 記入()

Dim i As Integer

For i = 1 To index
  Cells(ir, ic).Select 'モニター用
  Cells(ir, ic).Value = Cells(ii(i), 1).Value
  ir = ir + 1
Next

Cells(ir, ic).Value = "******"
ir = ir + 1

If ir > 65000 Then
  ic = ic + 1
  ir = 1
End If

End Sub

【42556】Re:組合せ
お礼  教えてください  - 06/9/14(木) 23:04 -

引用なし
パスワード
   みなさん、ありがとうございました。
ichinoseさんのを参考にさせていただきました。
ナイスプログラムさん、たくさんのアドバイスありがとうございました。

単純なことですが、求めたい合計値<組合せの数値の場合があったので30個まで組み合わせなくて済むことを忘れていました。

6882 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free