[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『数字を抽出した組み合わせ』（らん）
指定した数字の中から、６つの数字を抽出した組み合わせをすべて表示する方法があれば、宜しくお願いいたします。
Excel2002
WindowsXP
解答で無い上に、怪しい知識で申し訳ないのですが・・・
組み合わせの個数の計算は
nＣr＝n×(n-1)×･･･×(n-r+1)÷{r×(r-1)×･･･×2×1｝
（ｎ個の中からｒ個取り出すときの件数です。）
指定した文字が何個あるのか分からないですが 例えば１０個あるとすると、その中から６個取り出す時の 組み合わせの件数は 10*9*8*7*6*5/(6*5*4*3*2*1)=210件 になります。 それを全て表示したい と言うことですか？
(HANA)
簡単に作ってみました
Sub test()
Dim rng As Range, r As Range, a()
Dim outputTo As Range, b()
On Error Resume Next
Set rng = Application.InputBox("数値範囲の指定", Type:=8)
Err.Clear
If rng.Count < 6 Then Exit Sub
a = rng.Value
For i = 1 To rng.Count - 5
For ii = i + 1 To rng.Count - 4
For iii = ii + 1 To rng.Count - 3
For iv = iii + 1 To rng.Count - 2
For v = iv + 1 To rng.Count - 1
For vi = v + 1 To rng.Count
n = n + 1
ReDim Preserve b(1 To n)
b(n) = a(i, 1) & "," & a(ii, 1) & "," & a(iii, 1) _
& "," & a(iv, 1) & "," & a(v, 1) & "," & a(vi, 1)
Next vi, v, iv, iii, ii, i
Set outputTo = Application.InputBox("抽出先の指定", Type:=8)
outputTo.Cells(1, 1).Resize(n) = Application.Transpose(b)
Set rng = Nothing: Set outputTo = Nothing
Erase a, b
End Sub
(seiya)
回答ありがとうございます。 少し直してほしいところがありますので、よろしくお願いします。 結果の表示方法が１つのセル内に６個の数字が入るようにしてくれたのですが １つのセルに１つの数字が入り、１行の６個のセルに各数字が入るようにできますか。 それと、この方法だと２１個の数字までしかできないようなのですが ５０個くらいの数字までできませんか。 （らん）
COMBIN(50,6) = 15890700
どうやって表示するの？
(kym)
すみませんでした。行数が足りないことがわかりました。 では、結果の表示方法が１つのセルに１つの数字が入り １行の６個のセルに各数字が入るようにはできますか。 （らん）
Sub test()
Dim rng As Range, r As Range, a()
Dim outputTo As Range, b()
On Error Resume Next
Set rng = Application.InputBox("数値範囲の指定", Type:=8)
Err.Clear
If rng.Count < 6 Then Exit Sub
a = rng.Value
For i = 1 To rng.Count - 5
For ii = i + 1 To rng.Count - 4
For iii = ii + 1 To rng.Count - 3
For iv = iii + 1 To rng.Count - 2
For v = iv + 1 To rng.Count - 1
For vi = v + 1 To rng.Count
n = n + 1
ReDim Preserve b(1 to 6,1 To n)
b(1,n)=a(i,1):b(2,n)=a(ii,1):b(3,n)=a(iii,1)
b(4,n)=a(iv,1):b(5,n)=a(v,1):b(6,n)=a(vi,1)
Next vi, v, iv, iii, ii, i
Set outputTo = Application.InputBox("抽出先の指定", Type:=8)
outputTo.Cells(1, 1).Resize(n,6) = Application.Transpose(b)
Set rng = Nothing: Set outputTo = Nothing
Erase a, b
End Sub
(seiya)
行数が足りないため２１個の数字以上は表示できないことはわかりましたが 別の列の１行目から続きを表示するとか 別のシートに続きを表示することは可能なのでしょうか。 宜しくお願いいたします。（らん）
>別のシートに続きを表示することは可能なのでしょうか。 可能です。ですが、21個分のコードを書く気にはなれません。 悪しからず。 (seiya)
う〜ん、これはひょっとしてロト６の組合せを全て表示したいっちゅう事とちゃい まっしゃろか？ 図星でっしゃろ（笑 分け前は後で相談するとしてこんな塩梅でどうでっか？ seiyaはんのコードを元にして作っとりますから、あちらさんにも何某かの分け前は 覚悟しとってくらはい。 速度は考えてまへんからその点はご容赦を・・・。なあにこんなもんはいっぺん出した 後は用無しになりまっしゃろからなぁ。 キャリーオーバーやとなんぼ程懐に・・・（弥太郎） '-------------------------- Option Base 1 Sub ロト6()
Dim a(), b()
Dim t As Long, n As Long
Dim i As Integer, ii As Integer, iii As Integer, iv As Integer
Dim v As Integer, vi As Integer, f As Integer
On Error Resume Next
a = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, _
25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43)
t = 1: f = 1
For i = 1 To 43 - 5
For ii = i + 1 To 43 - 4
For iii = ii + 1 To 43 - 3
For iv = iii + 1 To 43 - 2
For v = iv + 1 To 43 - 1
For vi = v + 1 To 43
n = n + 1
ReDim Preserve b(1 To 6, 1 To n)
b(1, n) = a(i): b(2, n) = a(ii): b(3, n) = a(iii)
b(4, n) = a(iv): b(5, n) = a(v): b(6, n) = a(vi)
Next vi
Cells(t, f).Resize(n, 6) = Application.Transpose(b)
t = t + n
n = 0
If t > 50000 Then
t = 1: f = f + 6
End If
Next v, iv, iii, ii
If i = 3 Then
Sheets("sheet2").Select
t = 1: f = 1
End If
If i = 8 Then
Sheets("sheet3").Select
t = 1: f = 1
End If
Next i
Erase a, b
End Sub
皆様、アドバイスありがとうございます。 上記の方法でやってみたのですが、「１．２．３．４．５．６」の組み合わせなど 全てが表示されていないようなのですが、どうしてなのでしょうか。 初心者のわたしに再アドバイスお願いします。（らん）
1番目に「１．２．３．４．５．６」が出てきてますよ。 もしかして Option Base 1 を付けてないとか？ （やっちん）
やっちんさん毎度っ！ 原因はOption Base 1を抜かしてコピペしてますワえぇ。 それにしてもこれだけのデータを並べると重いなぁ（笑 検証するんもイヤになる・・・ （弥太郎）
実は将来（５，６年先）にイチャモンつけられるような気がするもんで、完結編を
そっと置いときます。
それはそうと、分配金はまだでっしゃろか？いいえぇ、決して忘れる事はありまへんでぇ。＾＾
（弥太郎）
'---------------------------
Option Base 1
Sub ロト6完結編()
Dim n As Long, a(), b
Dim i As Integer, ii As Integer, iii As Integer, iv As Integer
Dim v As Integer, vi As Integer, f As Integer
a = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, _
25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43)
ReDim b(1 To Rows.Count, 1 To 6)
idx = 1
For i = 1 To 43 - 5
For ii = i + 1 To 43 - 4
For iii = ii + 1 To 43 - 3
For iv = iii + 1 To 43 - 2
For v = iv + 1 To 43 - 1
For vi = v + 1 To 43
n = n + 1
b(n, 1) = a(i)
b(n, 2) = a(ii)
b(n, 3) = a(iii)
b(n, 4) = a(iv)
b(n, 5) = a(v)
b(n, 6) = a(vi)
Next vi
If n > 50000 Then
If f = 42 Then
idx = idx + 1
f = 0
End If
f = f + 1
Sheets(idx).Cells(1, (f - 1) * 6 + 1).Resize(n, 6) = b
n = 0
End If
Next v, iv, iii, ii
Next i
If n > 0 Then Cells(1, f * 6 + 1).Resize(n, 6) = b
Erase a, b
End Sub
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.