Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

6884 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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個ぐらいの数字からＸになる組合せを見つけなければならないのです…。


	【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個ぐらいの数字からＸになる組合せを見つけなければならないのです…。
こちらです。

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

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

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

の全３１通りで簡単に出ます。（コードは下記）
この組み合わせの数は「=2^5-1」で求められます。
例えば数字が６個なら「=2^6-1」で６３通り、
数字が１０個なら「=2^10-1」で１,０２３通りです。
つまり組み合わせの数は数字が１つ増えるごとに倍になり、「２のｎ乗－１」となります。
で、これが３０個になると「=2^30-1」で１,０７３,７４１,８２４通りとなります。
具体的に言うと「=(2^30)/65536/256」、シートを６４枚フルで使うことになります。
>30個ぐらいの数字からＸになる組合せを見つけなければならないのです…。
このままの条件だと、普通に考えて１０億個以上の組み合わせが出てくることになりますよ^^

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

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

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

'*****************************************************************************************************
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:組合せ

ナイスプログラム

- 06/9/13(水) 1:07 -


	引用なし

	パスワード

　今晩は。

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

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

【コード】

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

アクティブシートのセルＡ1からＡ２、Ａ３・・・Ａ３０に例えば、

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になる数の組合せを同じシートの
セルＣ１から書き込みます。
（全てのリストを出力しますから、一つでよいならmainを変更してください）

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

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


	【42529】Re:組合せ

ナイスプログラム

- 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個まで組み合わせなくて済むことを忘れていました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

6884 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free