[[20041213081301]]　『1から10までの数字のうち6個の組合せを一覧表示』（ＭＩＫＡ）　ページの最後に飛ぶ

『1から10までの数字のうち6個の組合せを一覧表示』（ＭＩＫＡ）

[どうすれば良いのでしょうか？]

を教えてください。ただし、配列は順不同で、たとえば「１．２．３．４．５．６」と「２．３．４．５．６．１」は、同じものとして表示しないようにしたいのです。よろしくお願いします。

Excel2002/WindowsXP

 おまたせしました。多分こんな感じでいいと思うんですが、
数学に詳しくないのでよくわからないのですが、その組み合わせの数っていくつ
あるんですか？？
とりあえずC1の値分抽出するようにしてみたんですけど、、どうかな？？
あまりたくさん要求すると動くかどうかわかりません。（￣□￣；）！！
やちゃちく試してみてください。ではでは、
v(=∩_∩=)v
（SoulMan）
　
Option Explicit
Sub らんだむ抽出()
'***************************************************
'変数の宣言
Dim MyDicA As Object, MyDicB As Object
Dim MyA() As Long
Dim i As Long, j As Long, k As Long, n As Long, x As Long
Dim L As Long, U As Long
Dim MyKey As Double
'C1の値が数字じゃなかったら中止
With Worksheets("Sheet1")
    If Not IsEmpty(.Range("C1").Value) And IsNumeric(.Range("C1").Value) Then
        If .Range("C1").Value < 65536 Then
            j = Int(.Range("C1").Value)
        Else
            Exit Sub
        End If
    Else
        Exit Sub
    End If
End With
'1から10までの乱数を発生させる為の定数
n = 10
'ディクショナリーBの生成
Set MyDicB = CreateObject("Scripting.Dictionary")
'ループ開始
    Do
    'ディクショナリーAの生成
    Set MyDicA = CreateObject("Scripting.Dictionary")
    'ループカウンターの初期化
    k = 0
    '配列MyAを用意
    ReDim MyA(1 To 6)
    '乱数発生ループの開始
        Do
            '乱数の初期化
            Randomize
            '乱数の取得
            MyKey = Int((n * Rnd) + 1)
            '重複していなかったら配列MyAに代入する
            If Not MyDicA.Exists(MyKey) Then
                k = k + 1
                MyA(k) = MyKey
                MyDicA.Add MyKey, Empty
            End If
        Loop Until k = 6
        L = LBound(MyA)
        U = UBound(MyA)
        '配列MyAをクイックソートで並び替える
        QuickSort MyA, L, U
        '変数MyKeyの初期化
        MyKey = Empty
        'MyKeyの生成
        For i = LBound(MyA) To UBound(MyA)
            MyKey = MyKey & MyA(i)
        Next
        'MyKeyが重複していなかったらMyDicBに代入
        If Not MyDicB.Exists(MyKey) Then
            MyDicB.Add MyKey, Empty
            x = x + 1
        End If
    '変数の初期化
    Set MyDicA = Nothing
    Erase MyA
Loop Until x = j 'Range("C1")の値分抽出する
'抽出先をクリアにして行列を入れ替えてMyDicBを出力する
With Worksheets("Sheet1").Range("A1")
    .EntireColumn.ClearContents
    .Resize(x).Value = Application.Transpose(MyDicB.Keys)
End With
'変数の初期化
Set MyDicB = Nothing
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Long
Dim i As Long, j As Long
MySMid = MySAry((MySLeft + MySRight) \ 2)
i = MySLeft
j = MySRight
    Do
        Do While MySAry(i) < MySMid
            i = i + 1
        Loop
        Do While MySAry(j) > MySMid
            j = j - 1
        Loop
        If i >= j Then Exit Do
        MySAry(i) = MySAry(i) Xor MySAry(j)
        MySAry(j) = MySAry(i) Xor MySAry(j)
        MySAry(i) = MySAry(i) Xor MySAry(j)
    Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, j + 1, MySRight
End Sub

http://ryusendo.no-ip.com/cgi-bin/upload/src/up0189.xls

 ちなみに210組の組み合わせが可能です。個数は =COMBIN(10,6) で求まります。
 おもしろそうなので、全ての組み合わせを出すのを、数式でチャレンジ！

	A	B	C	D	E	F
 　　1	5	6	7	8	9	10	←作業用データ行(手入力)
 　　2							
 　　3	1	2	3	4	5	6	←初期値行(手入力)
 　　4	1	2	3	4	5	7	←数式

 A4 には、=IF(B3<>B$1,A3,IF(A3<>A$1,A3+1,"END"))
 B4 には、=IF(C3<>C$1,B3,IF(B3<>B$1,B3+1,A4+1))
 C4とD4には、B4をコピーする。
 E4には、=IF(F3<>F$1,F3+1,E4+1)
 A4～E4を下にコピーします。
 A列に「END」と表示される直前の行までが有効です。
 この場合は3～212行の、合計210組が「全ての組み合わせ」です。

 ところで、[ＭＩＫＡ]さんからのコメントが無いですねぇ。
 (ちゅうねん)

 おはようございます。
 >合計210組が「全ての組み合わせ」です。
 そうなんですかぁ(^^;;;
 ということは、210より多く要求するとσ(^◇^;)のは無限ループになっちゃいますね。
 最初、いくつかなぁ？？と考えたのですが、わからなかったのでそのままにしてしまったぁ。。
 というわけでご使用の祭はその辺を改良してから使っておくんなましぃm(__)m
あっ！失礼！↓これを
If .Range("C1").Value < 65536 Then
これに↓
If .Range("C1").Value < 211 Then
で、いいのかな？？未検証
しかし、大きくかましてましたねぇ(V)o\o(V)ふぉふぉふぉ
 v(=∩_∩=)v
（SoulMan）

コメント返信：

[ 一覧(最新更新順) ]

[[20041213081301]] 『1から10までの数字のうち6個の組合せを一覧表示』（ＭＩＫＡ） ページの最後に飛ぶ

[[20041213081301]]　『1から10までの数字のうち6個の組合せを一覧表示』（ＭＩＫＡ）　ページの最後に飛ぶ