Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13426 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【5435】数字の組みあわせ方 さくら 03/5/13(火) 20:45 質問
【5456】Re:数字の組みあわせ方 ichinose 03/5/14(水) 18:39 回答
【5458】Re:数字の組みあわせ方 さくら 03/5/14(水) 19:55 質問
【5462】Re:数字の組みあわせ方 ichinose 03/5/15(木) 0:39 回答
【5481】Re:数字の組みあわせ方 さくら 03/5/15(木) 14:41 お礼
【5435】数字の組みあわせ方
質問  さくら  - 03/5/13(火) 20:45 -
引用なし
パスワード
   説明です
　　　　　　 C3に1　D3に2　E3に3　F3に4　G3に5　H3に6　
　　　　　　 C4に7　D4に8　E4に9　F4に10　と数字入力します。
　　　　　　
　　　そしてC7.D7.E7.F7.G7から組合せ
　　　　　　　 1, 2, 3, 4, 5
　　　　　　　 1, 2, 3, 4, 6
　　　　　　　 1, 2, 3, 4, 7
　　　　　　　 1, 2, 3, 4, 8
　　　　　　　 1, 2, 3, 4, 9
　　　　　　　 1, 2, 3, 4,10
　　　　　　　　: :　:　:　:
　　　　　　　 5, 7, 8, 9,10
　　　　　　　 6, 7, 8, 9,10

上記はC3〜F4を、10個と固定した時の組合せですが、
数字入力が5個のときや、6個、7個、8個、9個でも、くみあわせ出来るように
したいのですが、いまいちわからないので教えてください。

おしえてください・・。

よろしくおねがいします。
【5456】Re:数字の組みあわせ方
回答  ichinose  - 03/5/14(水) 18:39 -
引用なし
パスワード
   ▼さくら さん：
こんにちは。
>説明です
>　　　　　　 C3に1　D3に2　E3に3　F3に4　G3に5　H3に6　
>　　　　　　 C4に7　D4に8　E4に9　F4に10　と数字入力します。
>　　　　　　
>　　　そしてC7.D7.E7.F7.G7から組合せ
>　　　　　　　 1, 2, 3, 4, 5
>　　　　　　　 1, 2, 3, 4, 6
>　　　　　　　 1, 2, 3, 4, 7
>　　　　　　　 1, 2, 3, 4, 8
>　　　　　　　 1, 2, 3, 4, 9
>　　　　　　　 1, 2, 3, 4,10
>　　　　　　　　: :　:　:　:
>　　　　　　　 5, 7, 8, 9,10
>　　　　　　　 6, 7, 8, 9,10
>
>上記はC3〜F4を、10個と固定した時の組合せですが、
>数字入力が5個のときや、6個、7個、8個、9個でも、くみあわせ出来るように
>したいのですが、いまいちわからないので教えてください。
>
>おしえてください・・。
>
>よろしくおねがいします。
じっくりデバッグしてないんで、確認はして下さい
'==========================================================
Sub test()
　 Dim ans()
　 Dim 抜き取り As Long
　 抜き取り = 5
　 '　　　　 ↑の数字を6個、7個、8個、9個に変えてください
　 cmb = comb(ans(), Range("C3:H3,C4:F4"), 抜き取り)
　 Range(Cells(7, 4), Cells(cmb + 6, 4 + 抜き取り - 1)).Value = ans()
　 MsgBox "以上" & cmb & "通りのリストです"
End Sub
'===========================================================
Function comb(ans(), Optional rng As Range = Nothing, Optional seln As Long = 0, Optional ByVal myx As Long = 0, Optional ByVal ctx As Long = 0) As Long
'input rng : 組み合わせメンバーセル範囲
'　　　seln: 抜き取り数
'out　 ans() 組み合わせリスト
'　　　mxy ctx は　内部パラメータ指定不可
　　Dim crng As Range
　　Static svn As Long
　　Static myarray()
　　Static idx As Long
　　Static gyou As Long
　　Static mylim As Long
　　Dim cnt As Long
　　If seln > 0 Then
　　　 svn = seln
　　　 Erase myarray
　　　 i = 1
　　　 For Each crng In rng
　　　　 ReDim Preserve myarray(1 To i)
　　　　 myarray(i) = crng.Value
　　　　 i = i + 1
　　　　 Next
　　　 mylim = rng.Count
　　　 myx = 1
　　　 gyou = WorksheetFunction.Combin(rng.Count, seln)
　　　 comb = gyou
　　　 ReDim ans(1 To gyou, 1 To svn)
　　　 ctx = 1
　　　 idx = 1
　　　 End If
　　cnt = 0
　　Do While myx <= mylim And idx <= gyou
　　　If cnt > 0 And idx > 1 Then
　　　　 For i = 1 To ctx - 1
　　　　　 ans(idx, i) = ans(idx - 1, i)
　　　　　 Next
　　　　 End If
　　　ans(idx, ctx) = myarray(myx)
　　　If ctx + 1 <= svn Then
　　　　 Call comb(ans(), , , myx + 1, ctx + 1)
　　　　 End If
　　　myx = myx + 1
　　　idx = idx + 1
　　　cnt = cnt + 1
　　　Loop
　　idx = idx - 1
End Function
【5458】Re:数字の組みあわせ方
質問  さくら  - 03/5/14(水) 19:55 -
引用なし
パスワード
   ▼ichinose さん
こんばんは、有難うございます。
凄いです。感動しました。
処理が凄く早くてビックリしました。

ちょっと私の説明が悪かったです。
>>　　　　　　 C3に1　D3に2　E3に3　F3に4　G3に5　H3に6　
>>　　　　　　 C4に7　D4に8　E4に9　F4に10　と数字入力します。
>>　　　　　　
これは、C3からF4で、最大10個の数字で5列の組合せです。
本当は、C3に1　D3に2　E3に3　F3に4　G3に5　H3に6　
　　　　C4に（未入力）　D4に（未入力）　E4に（未入力）　F4に（未入力）
　とすると、1から6の数字で処理をすると
　1, 2, 3, 4, 5
　1, 2, 3, 4, 6
　1, 2, 3, 5, 6
　1, 2, 4, 5, 6
　1, 3, 4, 5, 6
　2, 3, 4, 5, 6
と、したい。

次は、1個数字を増やして、C3に1　D3に2　E3に3　F3に4　G3に5　H3に6　
　　　　C4に7　D4に（未入力）　E4に（未入力）　F4に（未入力）
1から7の数字で処理をすると、
　1, 2, 3, 4, 5
　1, 2, 3, 4, 6
　1, 2, 3, 4, 7
　1, 2, 3, 5, 6
　1, 2, 3, 5, 7
　1, 2, 3, 6, 7
　1, 2, 4, 5, 6
　1, 2, 4, 5, 7
　1, 2, 4, 6, 7
　1, 2, 5, 6, 7
　1, 3, 4, 5, 6
　1, 3, 4, 5, 7
　1, 3, 4, 6, 7
　1, 3, 5, 6, 7
　1, 4, 5, 6, 7
　2, 3, 4, 5, 6
　2, 3, 4, 5, 7
　2, 3, 4, 6, 7
　2, 3, 5, 6, 7
　2, 4, 5, 6, 7
　3, 4, 5, 6, 7
と、21個。
最小は1から5の組合せで、1個
最大は1から10の組合せで、252個

こんな感じにしたかったのです。

説明ヘタで申し訳ありませんでした。

良かったら説明など、入れてくださったら凄く嬉しいです。
ワガママ言ってスイマセン。


　　
【5462】Re:数字の組みあわせ方
回答  ichinose  - 03/5/15(木) 0:39 -
引用なし
パスワード
   ▼さくら さん：
こんばんは。
さくらさんの意図した結果ではなかったみたいですが、Function　combの引数の変更でいけますよね？

で、combの中身の説明ですが、コード見ておわかりだと思いますが、リカーシブルになっています。本当は、なるべくこういうコードは書かないようにしているのですが（非常にメンテナンスしづらいですよね、ちょっと前まで北朝鮮拉致ドラマ見てウルウルしてたらもう自分でもコード解析が大変です）、第1印象でこれしかないだろうと思ってしまったもので・・・。
コメントを付けようかと思いましたが、付けても説明がわかりづらいだろうと思いましたので、コードの考え方だけ。

仮に組み合わせのメンバーを
　　
1　2　3　4　5とし、
抜き取り数を3と限定しましょう。
1列　　　2列　　　3列
1　　　　2　　　　3
1　　　　2　　　　4
1　　　　2　　　　5
1　　　　3　　　　4
1　　　　3　　　　5
1　　　　4　　　　5
2　　　　3　　　　4
2　　　　3　　　　5
2　　　　4　　　　5
3　　　　4　　　　5

組み合わせリストは上記の10通りになりますが、
規則性として、各行とも1列<2列<3列　となっていますよね。
よって、配列の引数はこの条件を満たしながら変化させ、各列の値をひとつづつ変化させるロジックを考えました。


'=====================================================================
Function comb(ans(), Optional rng As Range = Nothing, Optional seln As Long = 0, Optional ByVal myx As Long = 0, Optional ByVal ctx As Long = 0) As Long
'input rng : 組み合わせメンバーセル範囲
'　　　seln: 抜き取り数
'out　 ans() 組み合わせリスト
‘　　　comb　組み合わせ総数
'　　　mxy ctx は　内部パラメータ指定不可
　　Dim crng As Range
　　Static svn As Long
　　Static myarray()
　　Static idx As Long
　　Static gyou As Long
　　Static mylim As Long
　　Dim cnt As Long
　　If seln > 0 Then
　　‘最初に呼び出されたときの初期設定を行います
　　‘リカーシブルによる2回目以降には実行されません
　 svn = seln
　　　 Erase myarray
　　　 i = 1
　　　 For Each crng In rng
　　　　 ReDim Preserve myarray(1 To i)
　　　　 myarray(i) = crng.Value
　　　　 i = i + 1
　　　　 Next
　　　 ‘このループで組み合わせ要素を１次元の配列に移行しています
　　　 mylim = rng.Count
　　　 myx = 1 ‘myarrayのインデックス
　　　 gyou = WorksheetFunction.Combin(rng.Count, seln)　‘組み合わせ数の算出
　　　 comb = gyou
　　　 ReDim ans(1 To gyou, 1 To svn)　‘組み合わせリストのエリア確保
　　　 ctx = 1　‘配列ansの列のインデックス
　　　 idx = 1　‘‘配列ansの行のインデックス
　　　 End If
　　cnt = 0
　　Do While myx <= mylim And idx <= gyou
　　　If cnt > 0 And idx > 1 Then
　　　　 For i = 1 To ctx - 1
　　　　　 ans(idx, i) = ans(idx - 1, i)
　　　　　 Next
　　　　 End If
　　　‘↑のループで当該列の直前までの列の要素をコピー
　　　ans(idx, ctx) = myarray(myx)
　　　‘↑このコードをループさせることで一つの列を配置を完成させていきます
　　　If ctx + 1 <= svn Then ‘抜き取り数に達していなければ、リカーシブルコール
　　　　 Call comb(ans(), , , myx + 1, ctx + 1)
　　　　 End If
　　　myx = myx + 1
　　　idx = idx + 1
　　　cnt = cnt + 1
　　　Loop
　　idx = idx - 1
End Function

前述したようにコメントも付けにくいし、付けてもわかりづらいと思いますが・・。
【5481】Re:数字の組みあわせ方
お礼  さくら  - 03/5/15(木) 14:41 -
引用なし
パスワード
   ▼ichinose さん
こんにちは。

色々とありがとうございます。
参考にしてみたいと思います。

また、解らなくなったときは宜しくお願いします

ありがとうございました
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13426 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free