Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3391 / 13644 ツリー ←次へ | 前へ→

【62533】複数単語の全組み合わせを作成したい MIE 09/7/29(水) 10:49 質問[未読]
【62542】Re:複数単語の全組み合わせを作成したい 超初心者 09/7/29(水) 14:04 発言[未読]
【62543】Re:複数単語の全組み合わせを作成したい MIE 09/7/29(水) 14:13 お礼[未読]
【62544】Re:複数単語の全組み合わせを作成したい SS 09/7/29(水) 14:17 発言[未読]
【62557】Re:複数単語の全組み合わせを作成したい ichinose 09/7/30(木) 8:28 発言[未読]

【62533】複数単語の全組み合わせを作成したい
質問  MIE  - 09/7/29(水) 10:49 -

引用なし
パスワード
   セルに、スペースで区切られた単語が入っています。
この単語の全ての組み合わせをVBAで作成したいのですが、可能でしょうか?

例えば

A B  ⇒ A B
   ⇒ B A

A B C ⇒ A B C
   ⇒ A C B
   ⇒ B A C
   ⇒ B C A
   ⇒ C A B
   ⇒ C B A

・・という感じです。

単語は1つのセルにスペースで区切られて入っており、単語数には上限が無い状況です。
また、処理したいセル数も数千になる可能性があり、処理速度も求められております。

何か方法がございましたら、是非ご伝授ください。
何卒宜しくお願いいたします。

【62542】Re:複数単語の全組み合わせを作成したい
発言  超初心者  - 09/7/29(水) 14:04 -

引用なし
パスワード
   ▼MIE さん:
難しいのではないでしょうか。

まず、結果がいくつになるかを計算してみると
想像しやすいかもしれません。

単語が1個なら1通り
単語が2個なら2通り
単語が3個なら6通り
単語が4個なら24通り
・・・・・
単語が10個なら3,628,800通り
・・・・
単語がn個ならn!通り

単語10個でエクセル2007の行数を超え、
単語14個で1シート内のセル数を超えます^^;

単語が何千となった場合に、シート数がいくつになるか・・・・
(1セル内に複数表示することも考えられますが)
その処理にPC(メモリ?)が耐えられるか・・・・

また、何億何兆以上のパターン算出がスピーディに終わるとも思えません。
パターン数を理解しており、2〜3年かけて出せれば上等!
というのであれば別ですが・・・^^;;

【62543】Re:複数単語の全組み合わせを作成したい
お礼  MIE  - 09/7/29(水) 14:13 -

引用なし
パスワード
   超初心者 さま

丁寧なご回答をありがとうございます。
もう少し、方法を検討してみます。

本当にありがとうございました!

【62544】Re:複数単語の全組み合わせを作成したい
発言  SS  - 09/7/29(水) 14:17 -

引用なし
パスワード
   ▼MIE さん:

力技でやるとこんな感じですかね
超初心者さんもおっしゃっているように文字列が8を超えると
シートに納まらなくなります。
Subの中で自分自身をCallしていますがプログラム上良いことなのか分かりません。
識者の方々に添削していただきたい気持ちでいっぱいです。

Option Explicit
Public AA As Variant
Public myarray As Variant

Sub test()
  Dim i As Long, j As Long, k As Long, l As Long, m As Long
  Dim txtNo As Long
  ReDim AA(10)
  Columns("B:IV").ClearContents
  m = Range("A65536").End(xlUp).Row
  
  For i = 1 To m
    myarray = Split(Cells(i, 1).Value, " ")
    txtNo = UBound(myarray, 1)
    
    ReDim AA(txtNo)
    Call ForNext(txtNo, txtNo, i)
  Next i
End Sub

Sub ForNext(m As Long, n As Long, o As Long)
  Dim i As Long, j As Long, k As Long, ARow As Long
  Dim txtA As String
  For i = 0 To n
    k = 0
    For j = n To m Step -1
      If AA(j) = i And AA(j) <> "" Then k = 1: Exit For
    Next j
    AA(m) = i
    If m > 0 And k = 0 Then
      Call ForNext(m - 1, n, o)
    End If
    If m = 0 And k = 0 Then
      txtA = myarray(AA(n))
      For j = n - 1 To 0 Step -1
        txtA = txtA & " " & myarray(AA(j))
      Next j
      Cells(Cells(65536,o+1).End(xlUp).Row+1, o+1).Value = txtA
    End If
  Next i
End Sub


>セルに、スペースで区切られた単語が入っています。
>この単語の全ての組み合わせをVBAで作成したいのですが、可能でしょうか?
>
>例えば
>
>A B  ⇒ A B
>   ⇒ B A
>
>A B C ⇒ A B C
>   ⇒ A C B
>   ⇒ B A C
>   ⇒ B C A
>   ⇒ C A B
>   ⇒ C B A
>
>・・という感じです。
>
>単語は1つのセルにスペースで区切られて入っており、単語数には上限が無い状況です。
>また、処理したいセル数も数千になる可能性があり、処理速度も求められております。
>
>何か方法がございましたら、是非ご伝授ください。
>何卒宜しくお願いいたします。

【62557】Re:複数単語の全組み合わせを作成したい
発言  ichinose  - 09/7/30(木) 8:28 -

引用なし
パスワード
   おはようございます。
新規ブックにて試してみてください

標準モジュールに

'=================================================================
Option Explicit
Sub sample()
  Dim rng As Range
  Dim crng As Range
  Dim pernum As Long
  Dim myarray As Variant
  Call サンプルデータ作成
  MsgBox "これらのデータの順列リストを作成します"
  Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
  If rng.Row > 1 Then
    For Each crng In rng
     myarray = Split(crng.Value, " ")
     pernum = init_permut(myarray, UBound(myarray) + 1)
     ReDim aa(1 To pernum, 1 To 1)
     ReDim bb(1 To UBound(myarray) + 1)
     pernum = 1
     Do While get_permut(bb()) = 0
       aa(pernum, 1) = Join(bb(), " ")
       pernum = pernum + 1
     Loop
     Range(Cells(1, crng.Row), Cells(pernum - 1, crng.Row)).Value = aa()
     Call close_permut
    Next
  End If
End Sub
'========================================================================
Sub サンプルデータ作成()
  Cells.Clear
  Range("a1:a4").Value = [{"順列標本";"a b c";"a b c d e f";"a b c d e f g"}]
End Sub


別の標準モジュールに

順列リスト作成プログラム

'=======================================================================
Option Explicit
  Private p_svn As Long '抜き取り数保存
  Private p_myarray() '順列対象値の配列
  Private p_idx() As Long '配列の各位置のボインタ
Function init_permut(rng As Variant, seln As Long) As Double
' 順列リスト作成 初期化処理
' input rng 順列の標本配列
'    seln 抜き取り数
' ourput init_permut 順列数
  On Error Resume Next
  Dim crng As Variant
  Dim g0 As Long
  p_svn = seln
  Erase p_myarray()
  Erase p_idx()
  g0 = 1
  For Each crng In rng
   ReDim Preserve p_myarray(1 To g0)
   p_myarray(g0) = crng
   g0 = g0 + 1
   Next
  ReDim p_idx(1 To seln)
  For g0 = 1 To UBound(p_idx())
   p_idx(g0) = 1
   Next
  init_permut = WorksheetFunction.Permut(UBound(p_myarray()), seln)
End Function
'========================================================================
Function get_permut(ans(), Optional ByVal n_cnt As Long = 1) As Long
' 順列リストを順次取得する
' input ナシ
' output ans() 順列リストを格納する1次元配列 lbound(ans())=1であること
' get_permut 0 正常に順列リストを取得  1 データの終わり
  Dim idx As Long
  Dim jdx As Long
  Dim retcode As Long
  get_permut = 1
  For idx = p_idx(n_cnt) To UBound(p_myarray())
    retcode = 0
    For jdx = LBound(p_idx()) To n_cnt - 1
     If p_idx(jdx) = idx Then
       retcode = 1
       Exit For
       End If
     Next jdx
    If retcode = 0 Then
     ans(n_cnt) = p_myarray(idx)
     p_idx(n_cnt) = idx
     If n_cnt < UBound(p_idx()) Then
       get_permut = get_permut(ans(), n_cnt + 1)
     Else
       p_idx(n_cnt) = idx + 1
       get_permut = 0
       End If
     End If
    If get_permut = 0 Then Exit For
    Next idx
  If get_permut = 1 Then
   p_idx(n_cnt) = 1
   End If
End Function
'========================================================================
Sub close_permut()
' 順列リスト作成 終了処理
  Erase p_myarray()
  Erase p_idx()
End Sub


これでsampleを実行してください。

3391 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free