組み合わせの一覧表示（Microsoft Excel）

Sub TestCNR()

Cnr 10, 4 End Sub

Sub Cnr(n, r)

i = 1     For j = 1 To r         Cells(i, j).Value = j     Next

Do Until Finished(n, r, i)

j = FindFirstSmall(n, r, i)

For k = 1 To j — 1             Cells(i + 1, k).Value = Cells(i, k).Value         Next         Cells(i + 1, j).Value = Cells(i, j).Value + 1         For k = j + 1 To r             Cells(i + 1, k).Value = Cells(i + 1, k - 1).Value + 1         Next         i = i + 1     Loop End Sub

Function Finished(n, r, i)

Temp = True

For j = r To 1 Step -1         If Cells(i, j).Value <> j + (n - r) Then             Temp = False         End If     Next     Finished = Temp End Function

Function FindFirstSmall(n, r, i)

j = r     Do Until Cells(i, j).Value <> j + (n - r)

j = j - 1     Loop     FindFirstSmall = j End Function

Sub FindSets()

Dim iA() As Integer     Dim sUniv As String     Dim iWanted As Integer     Dim j As Integer     Dim k As Integer

sUniv = Cells(1, 1).Value     iWanted = Cells(2, 1).Value

ReDim iA(iWanted)

For j = 1 To iWanted         iA(j) = j     Next j

iRow = PutRow(iA, sUniv, 1)



Do Until DoneYet(iA, Len(sUniv))

j = WorkHere(iA, Len(sUniv))

iA(j) = iA(j) + 1         For k = j + 1 To iWanted             iA(k) = iA(k - 1) + 1         Next k         iRow = PutRow(iA, sUniv, iRow)

Loop End Sub

Function DoneYet(iB, n) As Boolean     iMax = UBound(iB)

Temp = True     For j = iMax To 1 Step -1         If iB(j) <> j + (n - iMax) Then             Temp = False         End If     Next     DoneYet = Temp End Function

Function WorkHere(iB, n) As Integer     iMax = UBound(iB)

j = iMax     Do Until iB(j) <> j + (n - iMax)

j = j - 1     Loop     WorkHere = j End Function

Function PutRow(iB, sUniv, i)

iMax = UBound(iB)

sTemp = ""

For j = 1 To iMax         sTemp = sTemp & Mid(sUniv, iB(j), 1)

Next j     Cells(i, 2).Value = sTemp     PutRow = i + 1 End Function