ここから本文です

N個の中からr個の組み合わせを列挙するプログラムを、二進数表記を応用して作りま...

mar********さん

2019/6/611:09:37

N個の中からr個の組み合わせを列挙するプログラムを、二進数表記を応用して作りました。

以下はN=15、r=8の例ですが、Nとrを所望のものに変えれば、計算リソースが枯渇しない限り「N個の中からr個の組み合わせ」を全て列挙出来るハズです。

今回は「1から2^N-1 までの全ての数に対して二進数変換を試行して、ビット数がrであるもののみを採択する」
という方法なのですが、もう少し早くなりませんでしょうか?(Nとrは頻繁に取り替えるので、変数として持たせておいて所望のものを入力すればよいようにしたい)


Sub 組み合わせの列挙()
Dim 配列()
N = 15
r = 8

要素数 = WorksheetFunction.Combin(N, r)
ReDim 配列(1 To 要素数)

cnt = 1
Nmax = (2 ^ N) - 1
For i = 1 To Nmax
ビット数 = 0: 余 = i
For j = 0 To N
商 = 余 \ 2 ^ (N - j)
余 = 余 Mod 2 ^ (N - j)
ビット数 = ビット数 + 商
Next j
If ビット数 = r Then
配列(cnt) = i: cnt = cnt + 1
End If
Next i

For i = 1 To 要素数
余 = 配列(i)
For j = 0 To N
商 = 余 \ 2 ^ (N - j)
余 = 余 Mod 2 ^ (N - j)
Cells(i + 1, j + 1) = 商
Next j
Cells(i + 1, 1) = 配列(i)
Next i
Cells(1, 1) = "10進表記": For j = 1 To N: Cells(1, j + 1) = "要素" & j: Next j

End Sub

閲覧数:
56
回答数:
1
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

uso8megaさん

2019/6/615:54:12

(n)C(r)で済むのに2^n回している
Cellsに大量にアクセスしている
を何とかすれば多少は早くなるかと。

VBScript でのみ検証済みで Excel
では未検証ですが多分 動くかと。

Option Explicit

Sub nc(n, r, c())
  Dim j, k
  For j = r To 0 Step -1
    c(j) = c(j) + 1
    For k = j + 1 To r: c(k) = c(k - 1) + 1: Next
    If c(j) <= n - r + j Then Exit For
  Next
End Sub

Sub Cmb()
  Dim n, r, m, i, j, c, o
  n = 15
  r = 8
  m = WorksheetFunction.Combin(n, r)
  ReDim c(r), o(m, n)
  For j = 0 To r: c(j) = j: Next
  o(0, 0) = "10進表記"
  For j = 1 To n: o(0, j) = "要素" & j: Next
  i = 1
  Do While c(0) <= 0
    For j = 0 To n: o(i, j) = 0: Next
    For j = 1 To r
      o(i, 0) = o(i, 0) + 2 ^ (c(j) - 1)
      o(i, n + 1 - c(j)) = 1
    Next
    i = i + 1
    nc n, r, c
  Loop
  Cells(1, 1).Resize(m + 1, n + 1).Value = o
End Sub

  • 質問者

    mar********さん

    2019/6/716:05:10

    回答頂きありがとうごっざいました。”Sub Cmb” を以下の18行目で「型が一致しません」となります。
    (このとき”c”がハイライトされています)★の部分を削除したらNやrを小さくしても無限ループに陥るようです。★の部分をCall nc(n, r, c())にしたりByRefにしたりしても「型が一致しません」となります。

    Sub Cmb()
    Dim n, r, m, i, j, c, o
    n = 15
    r = 8
    m = WorksheetFunction.Combin(n, r)
    ReDim c(r), o(m, n)
    For j = 0 To r: c(j) = j: Next
    o(0, 0) = "10進表記"
    For j = 1 To n: o(0, j) = "要素" & j: Next
    i = 1
    Do While c(0) <= 0
    For j = 0 To n: o(i, j) = 0: Next
    For j = 1 To r
    o(i, 0) = o(i, 0) + 2 ^ (c(j) - 1)
    o(i, n + 1 - c(j)) = 1
    Next
    i = i + 1
    nc n, r, c '★
    Loop
    Cells(1, 1).Resize(m + 1, n + 1).Value = o
    End Sub

  • その他の返信(4件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2019/6/11 09:15:27

回答頂きありがとうございました。

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる