Excel 全通り組み合わせ

マクロ全通り組み合わせを作成しようとしています。
セルのA1から7までに
りんご
みかん
ばなな
ぶどう
すいか
めろん
いちご
の値があり、これをC列からI列に出力したいです。
値が全てブランク、ひとつだけ、ふたつだけといった形で全ての組み合わせを出したいです。

伝わりにくいかも知れませんが、よろしくお願いします。

No.2 ベストアンサー 回答者： 30246kiku 回答日時： 2015/08/19 16:40

以下でどうなりますか

★ 部分を有効にすると、左詰め表示します


Public Sub Samp1()
　　Dim vA As Variant, vB As Variant
　　Dim i As Long, j As Long, k As Long, n As Long
　　
　　vA = WorksheetFunction.Transpose( _
　　　　Range("A1", Cells(Rows.Count, "A").End(xlUp)))

　　Application.ScreenUpdating = False
　　With Range("C1").Resize(, UBound(vA))
　　　　.EntireColumn.Clear
　　　　k = 1
　　　　For i = 1 To UBound(vA)
　　　　　　ReDim vB(1 To UBound(vA))
　　　　　　j = 1
　　　　　　n = 0
　　　　　　Do While (1)
　　　　　　　　While (n < i)
　　　　　　　　　　vB(j) = vA(j)
　　　　　　　　　　j = j + 1
　　　　　　　　　　n = n + 1
　　　　　　　　Wend

　　　　　　　　k = k + 1
　　　　　　　　.Rows(k).Value = vB

　　　　　　　　vB(j - 1) = Empty
　　　　　　　　n = n - 1
　　　　　　　　If ((UBound(vA) - j + 1) < (i - n)) Then
　　　　　　　　　　j = j - 2
　　　　　　　　　　Do While (j > 0)
　　　　　　　　　　　　If (vB(j) <> "") Then
　　　　　　　　　　　　　　vB(j) = Empty
　　　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　　　n = n - 1
　　　　　　　　　　　　　　If ((UBound(vA) - j + 1) >= (i - n)) Then Exit Do
　　　　　　　　　　　　　　j = j - 1
　　　　　　　　　　　　End If
　　　　　　　　　　　　j = j - 1
　　　　　　　　　　Loop
　　　　　　　　　　If (j < 1) Then Exit Do
　　　　　　　　End If
　　　　　　Loop
　　　　Next

　　　　With .Resize(k)
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　On Error Resume Next
'　　　　　　.SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft ' ★
　　　　　　.Columns.AutoFit
　　　　End With
　　End With
　　Application.ScreenUpdating = True
End Sub

この回答へのお礼

30246kikuさん
ありがとうございます。

ほぼイメージ通りなのですが、一点気になるところがあるので質問させてください。
ふた通り以降の組み合わせで、りんごとみかんの出力は問題ないのですが、みかん以降の組み合わせを出力する際にりんごと組み合わせるパターンがなくなってしまいます。
りんごの組み合わせの場合は、6通りでみかんの組み合わせの場合は5通り、以降は4通り、3通りと減っている形になります。
これを、全て6通りの出力パターンにしたいです。
以降のりんご、みかん、ばななの組み合わせの際も同様です。伝わりにくいかも知れませんが、対処法を教えて頂けないでしょうか
よろしくお願い致します。

お礼日時：2015/08/20 10:40

No.1 回答者： WindFaller 回答日時： 2015/08/19 14:04

こんにちは。

基本的に、数式では、
n C r
n=総数 r=抜き取り数

ですね。

おっしゃっている「ひとつだけ、ふたつだけ」というのは、[抜き取り数]だと思います。

しかし、「値が全てブランク」というのは、
論理的にはあるかもしれませんし、Excelでも、
=COMBIN(7,0)　　答えは1

として成立するようですが、これは省かせていただきます。

検算方法としては、　= COMBIN(7, i)
7つの内1つ　　　　7
7つの内2つ　　　　21
7つの内3つ　　　　35
7つの内4つ　　　　35
7つの内5つ　　　　21
7つの内6つ　　　　7
7つの内7つ　　　　1
----
合計：127
ということでよろしいでしょうか？
以下は、古くからある組合せアルゴリズムを今風にアレンジしたものです。

'//

Dim n_TOTAL　As Long 'Numbers of total -全体の個数
Dim r_PICK　 As Long　'Numbers of extraction -抽出数
Dim k As Long
Sub MakingCombin()
　Dim Stock() As Variant
　Dim i As Long
　n_TOTAL = Cells(Rows.Count, 1).End(xlUp).Row　'A列のA1から
　For r_PICK = 1 To n_TOTAL
　　ReDim Stock(0)
　　For i = 1 To n_TOTAL
　　　ReDim Preserve Stock(i - 1)
　　　Stock(i - 1) = Cells(i, 1).Value
　　Next i
　　Call sCombinations(Stock, r_PICK)
　Next r_PICK
End Sub

Sub sCombinations(ByRef Stock() As Variant, ByVal r As Long)
　　Dim num As Long
　　Dim ar As Variant
　　Dim i As Long, j As Long
　　'Dim k As Long
　　num = UBound(Stock) - LBound(Stock)
　　r = r - 1
　　ReDim ar(0, r)
　　Dim idx() As Long
　　ReDim idx(0 To r)
　　For i = 0 To r
　　　　idx(i) = i
　　Next i
　　Do
　　　　For j = 0 To r
　　　　　　 ar(0, j) = Stock(idx(j))
　　　　Next j
　　　　　k = k + 1
　　　　　Cells(k, 3).Resize(, r_PICK).Value = ar 'C列からの出力
　　　　i = r
　　　　While (idx(i) = num - r + i)
　　　　　　i = i - 1
　　　　　　If i = -1 Then
　　　　　　　　Exit Sub
　　　　　　End If
　　　　Wend
　　　　idx(i) = idx(i) + 1
　　　　For j = i + 1 To r
　　　　　　idx(j) = idx(i) + j - i
　　　　Next j
　　Loop
End Sub
'///

この回答へのお礼

WindFallerさん
ありがとうございます。
VBAの知識が浅いので参考になりました。

お礼日時：2015/08/20 10:41