VBA nCrの列挙

Question

似たような質問が過去にあるかと思いますが、初心者であるためご容赦いただけたらと思います。宜しくお願い致します。

Excel vbaでnCrの組み合わせを全て列挙するものコードを考えています。
リストとして1-10があり、指定したrを抽出した組み合わせを表示するようなものです。
例　r=2

3 1+2
4 1+3
5 1+4
:
r=3

6 1+2+3
7 1+2+4
:

For文で繰り返すことで書いていましたが
調べると再帰関数やフィボナッチを考慮して
書くことができるとのことでぜひともどなたかご教示いただけたらと思います。
何卒よろしくお願い致します。

Comments

[y_waiwai]

説明不足すぎて意味不明です

[Uuas14088]

申し訳ございません。編集途中で投稿がされてしまっためです。

Answer 1

ミスです消去します。

Answer 2

こんなもんかな?
シートに書き出します。

ちなみに再帰ルーチン中のループをnからstep-1でやっているのは
こうすると処理中は配列要素数をチェックする必要がないからです。
ただしこのため処理結果のリストが1からはじまりません。

補足(2020/08/05):
下のサンプルはn=10, r=3の時だけです。r=1～10のすべての組み合わせを得たい場合は、
呼び出し元にてfor文等を使い、rを1から10まで変化させてnCrを呼び出してください。

Option Explicit
 '
 ' グローバル
 '
 Dim rx As Long
 Dim elm As Variant
'
' 呼び出し元
'
Private Sub CommandButton1_Click()
  elm = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)             ' 処理対象の配列。※0はindex調整のダミー
  rx = 1                                                    ' 結果書き込み行位置
  Call nCr(10, 3, "")                                       ' n=10, r=3。
End Sub
'
' 再帰ルーチン
'
Private Function nCr(ByVal n As Long, ByVal r As Long, ByVal txt As String)
  If (r = 0) Then                                           ' 再帰の底
    rx = rx + 1                                             ' 書き込み行位置
    Me.Cells(rx, "B") = Mid$(txt, 2)                        ' 先頭"+"を除いてシートに書き込み。
  Else
    Dim ix As Long
    For ix = n To 1 Step -1
      Call nCr(ix - 1, r - 1, "+" & elm(ix) & txt)          ' 自分より右にある要素のすべての組み合わせ
    Next
  End If
End Function

Answer 3

依頼と少し違う感じかも知れませんが、こんなのではどうでしょうか。A列に結果書き込まれます。

Option Explicit
'変数域
Private lRow As Long
Private lCol As Long
Private giLayer As Integer
Private giWorkLayerMax As Integer
'定数域
Private Const giCountMax As Integer = 10
Private Const giLayerMax As Integer = 3
' ***********************************************
' 開始
' ***********************************************
Private Sub Test_Sample_Miniature()
    Dim iX As Integer
    Range("A:A").Clear
    lRow = 0
    lCol = 1
    For iX = 1 To giLayerMax
        giLayer = 0
        giWorkLayerMax = iX
        lRow = lRow + 1
        Cells(lRow, lCol) = "(r = " & iX & ")"
        Call 自己参照(0, "")
    Next
End Sub
' ***********************************************
' 自己参照
' ***********************************************
Private Function 自己参照(iLayer As Integer, strPara As String) As Boolean
    Dim iX As Integer
    Dim intWorkLay As String
    Dim strWorkPar As String
    giLayer = giLayer + 1
    intWorkLay = giLayer
    strWorkPar = strPara
    For iX = 0 To giCountMax
        If giLayer < giWorkLayerMax And iX <> giCountMax Then
            If strWorkPar = "" Then strPara = iX + 1 Else strPara = strWorkPar & "+" & iX + 1
            Call 自己参照(iLayer, strPara)
            giLayer = giLayer - 1
        Else
            If iX <> giCountMax Then
                lRow = lRow + 1
                strPara = strWorkPar & "+" & iX + 1
                Cells(lRow, lCol) = strPara
            End If
        End If
    Next
End Function

(追記)

Option Explicit
'変数域
Private lRow As Long
Private lCol As Long
Private giLayer As Integer
Private giWorkLayerMax As Integer
'定数域
Private Const giCountMax As Integer = 10
Private Const giLayerMax As Integer = 3
' ***********************************************
' 開始
' ***********************************************
Private Sub Test_Sample_Miniature()
    Dim iX As Integer
    Range("A:A").Clear
    lRow = 0
    lCol = 1
    For iX = 1 To giLayerMax
        giLayer = 0
        giWorkLayerMax = iX
        lRow = lRow + 1
        Cells(lRow, lCol) = "(r = " & iX & ")"
        Call 自己参照(0, "")
    Next
End Sub
' ***********************************************
' 自己参照
' ***********************************************
Private Function 自己参照(iLayer As Integer, strPara As String) As Boolean
    Dim iX As Integer
    Dim intWorkLay As String
    Dim strWorkPar As String
    giLayer = giLayer + 1
    intWorkLay = giLayer
    strWorkPar = strPara
    For iX = 0 To giCountMax
        If giLayer < giWorkLayerMax And iX <> giCountMax Then
            If strWorkPar = "" Then strPara = iX + 1 Else strPara = strWorkPar & "+" & iX + 1
            Call 自己参照(iLayer, strPara)
            giLayer = giLayer - 1
        Else
            If iX <> giCountMax Then
                lRow = lRow + 1
                strPara = strWorkPar & "+" & iX + 1
                Cells(lRow, lCol) = strPara
            End If
        End If
    Next
End Function

(再追記)

Option Explicit
'変数域
Private lRow As Long
Private lCol As Long
Private gintLayer As Integer
'定数域
Private Const giCountMax As Integer = 10
Private Const giLayerMax As Integer = 3
' ***********************************************
' 開始
' ***********************************************
Private Sub Test_Sample_Miniature()
    Dim iX As Integer
    Range("A:A").Clear: lRow = 0: lCol = 1
    For iX = 1 To giLayerMax
        gintLayer = iX
        lRow = lRow + 1: Cells(lRow, lCol) = "(r = " & iX & ")"
        Call 自己参照(1, 1, "")
    Next
End Sub
' ***********************************************
' 自己参照
' ***********************************************
Private Function 自己参照(iPLayer As Integer, iPNextCount As Integer, strParam As String) As Boolean
    Dim iX     As Integer
    Dim iY     As Integer
    Dim MyStr  As String
    For iX = iPNextCount To giCountMax
        If iPLayer < gintLayer Then
            If giCountMax > iX Then
                Call 自己参照(iPLayer + 1, iX + 1, strParam & "+" & iX)
            End If
        Else
            MyStr = strParam & "+" & iX
            lRow = lRow + 1
            Cells(lRow, lCol) = Mid(MyStr, 2)
        End If
    Next
End Function

Answer 4

あー、なるほど、依頼の内容の意味を理解しました。

これをVBAで実現するには、かなりの高スペックマシンが要求されます。
この手のアルゴリズムは、一般的に、回帰処理をする為です。
度重なる回帰処理をすると、メモリを多く使用する為、スタック領域不足のエラーが発生します。

VBAのプログラミングで、一番の苦しいのは、動的配列が、プロシージャ外で使えない点や、ポインタ等の技が使えない点です。そのために、メモリ不足やスタック領域不足が発生しやすくなるのです。

他のプログラミング言語では、ポインタ等が使えるので、スタック領域不足になりにくいです。
私が考えたアルゴリズムでは、合計数が９で、スタック領域が不足してしまいました。

VBAは、基本的にマクロ言語の為、ExcelやWordを操作する為の道具で、計算処理する為には向きません。
VBAではなく、本格的なプログラム言語で実装されると、実現が可能かもしれません。
PythonやCなど。

私の意見では、VBAで実装することは、諦めた方が得策です。

でも、何かの参考になるかもしれませんので、ソースコードを入れておきます。

Option Explicit

Public p As Integer
Public n As Integer

Public Sub sample1()
    Dim i As Integer
    Dim a
    
    n = InputBox("求める合計数 n の入力 (整数)")
    p = InputBox("数値の個数 p の入力（整数）")
    
    ReDim c(1 To p) As Integer
    
    For i = 1 To p - 1
        c(i) = 1
    Next i
    c(p) = n - i + 1
    
    Call combi(c)
    
End Sub

Private Sub combi(c)
    Dim ret As String
    Dim i As Integer
    Dim j As Integer
    Dim a As Integer
    
    
    If c(1) > Int(n / p) Then
        Exit Sub
    Else
        If ck(c) Then
            ret = ""
            For i = 1 To p
                ret = ret & c(i) & "+"
            Next i
            ret = Left(ret, Len(ret) - 1)
            
            Debug.Print n & "C" & p & " = " & ret
            
        End If
        
        c(p) = c(p) - 1
        If c(p) > 1 Then
            a = 0
            For i = (p - 1) To 1 Step -1
                If c(i) <= (n - p) Then
                    c(i) = c(i) + 1
                Else
                    c(i) = 1
                End If
                Call combi(c)
            Next i
        Else
            c(p) = n - p
        End If
        
    End If
End Sub

Private Function ck(c) As Boolean
    Dim i As Integer
    Dim a As Integer
    a = 0
    For i = 1 To p
        a = a + c(i)
    Next i
    If a = n Then
        ck = True
    Else
        ck = False
    End If
End Function