Excel VBA質問箱 IV

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

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


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

【44401】単語群による順列の生成 レイ 06/11/15(水) 2:18 質問[未読]
【44402】Re:単語群による順列の生成 ichinose 06/11/15(水) 7:49 発言[未読]
【44405】Re:単語群による順列の生成 レイ 06/11/15(水) 9:40 お礼[未読]

【44401】単語群による順列の生成
質問  レイ E-MAIL  - 06/11/15(水) 2:18 -

引用なし
パスワード
   皆様、初めまして。ハンドルネームで失礼致します。

お時間の空いているときでも結構ですので
どうぞ、よろしくお願いします。


現在、エクセルで題名のような事をやっています。

関数での単語順列作成はできたのですが、
ファイルサイズが異常に大きくなってしまいとても困っています。

この様なものをVBAで作ろうとしています。
対応したいエクセルのバージョンは、Excel2000〜2005です。

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
例)エクセルの表
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
──┬─────┬─────┬──────────────
  │ 列A  │ 列B  │ 列C
──┼─────┼─────┼──────────────
行1│ 単語1 │ 単語1 │ 保存用のキー
──┼─────┼─────┼──────────────
行2│     │ 単語2 │
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
行n│     │ 単語n)│
──┼─────┼─────┼──────────────

という単語群があります。

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
1.列Aの単語1が必ず入った、列Bの単語との順列生成
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
(1)
ポイントは列Aの単語1は必ず含むということです。
列Aの単語は、1個だけ指定します。

(2)

列Bの単語nは

2構成の場合100個まで対応したいのです。
3構成の場合50個まで対応したいのです。
4構成の場合25個まで対応したいのです。

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
2.列Aの単語1を含んだ2構成から4構成まで生成
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜

(1)
単語の間には「半角ブランク」を入れる。

例1)
単語が5個ある場合の3構成はこうなります。
この場合は、A列の単語1が必ず含む順列が36個できます。

単語1 単語2 単語3
単語1 単語2 単語4
単語1 単語2 単語5

例2)
これは4構成で単語が6個ある場合。
この場合は、A列の単語1が必ず含む順列が240個できます。

単語1 単語2 単語3 単語4
単語1 単語2 単語3 単語5
単語1 単語2 単語3 単語6

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
3.生成した順列をテンプレートシートに5000行毎に書きだし。
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜

(1)テンプレートシートのB列に格納
──┬─────┬───────────────────
  │ 列A  │ 列B
──┼─────┼───────────────────
行1│ AAA │ 単語1 単語2 単語3 単語4
──┼─────┼───────────────────
行2│ AAA │ 単語1 単語2 単語3 単語5
──┼─────┼───────────────────
行3│ AAA │ 単語1 単語2 単語3 単語6
──┼─────┼───────────────────
行n│ AAA │ 単語n(5000行まで)
──┼─────┼───────────────────


(2)5000行に達したらテンプレートシートをCSVとして保存
(3)テンプレートシートに生成した部分をクリア
(4)再度1行目から書きだし
(5)終了するまでループ

4.ファイル名は、「列Cの保存キー_yyyymmdd_hhmmss.csv」


3,4については私もできるかな?と思うのですが、
1,2はどうすればいいのか混乱してしまいます。

もしかすると私レベルの知識だと一筋縄ではいかないものなのかもしれません。
どうにかなりませんでしょうか?

どうぞよろしくお願いいたします。

追記
メールアドレスは公開しております。
もし、サンプルを送っていただける場合は、お知らせください。

【44402】Re:単語群による順列の生成
発言  ichinose  - 06/11/15(水) 7:49 -

引用なし
パスワード
   ▼レイ さん:
おはようございます。
細かい仕様に不明な点がありますが、
この問題、順列リストが作成できれば、処理の早い遅いの差はあっても
概ね出来そうですけどね!!
順列リスト作成するコードは以前作ったことがあります。


こんな例を考えます。

アクティブシートの
セルA1〜E1にそれぞれ

a b c d e

というアルファベットが入っています。
(これは、アクティブシートのA1〜E1に予め入力して置いてください)

この5個の文字から3を抜き出す順列リストを考えます。
但し、aという文字は必ず入っていること。

順列リストは、セルA5から、下行に書き出すことにします。


標準モジュールに
'===============================================================
Sub main()
  Dim ans(1 To 2) As Variant
  Dim g0 As Long
  Dim myarray As Variant
  Call init_permut(Range("b1:e1"), 2)
  g0 = 5
  Do While get_permut(ans()) = 0
    myarray = get_reconvert(Range("a1").Value, ans())
    Do While TypeName(myarray) = "Variant()"
     Cells(g0, 1).Value = Join(myarray, " ")
     g0 = g0 + 1
     myarray = get_reconvert
     Loop
    Loop
  Call close_permut
End Sub
'=======================================================================
Function get_reconvert(Optional ByVal myvalue As Variant = "", Optional ByVal myarray As Variant) As Variant
  Static s_val As Variant
  Static s_array As Variant
  Static cnt As Long
  Dim g0 As Long, g1 As Long
  If myvalue <> "" Then
    s_val = myvalue
    s_array = myarray
    cnt = LBound(s_array)
    End If
  If cnt > UBound(s_array) + 1 Then
    get_reconvert = ""
  Else
    ReDim ans(LBound(s_array) To UBound(s_array) + 1)
    g1 = LBound(s_array)
    For g0 = LBound(s_array) To UBound(s_array)
     If cnt = g0 Then
       ans(g1) = s_val
       g1 = g1 + 1
       End If
     ans(g1) = s_array(g0)
     g1 = g1 + 1
     Next
    If cnt = g0 Then
     ans(g1) = s_val
     End If
    cnt = cnt + 1
    get_reconvert = ans()
    End If
End Function


別の標準モジュールに
順列リスト作成ルーチン
'===============================================================
Option Explicit
  Private p_svn As Long '抜き取り数保存
  Private p_myarray() '順列対象値の配列
  Private p_idx() As Long '配列の各位置のボインタ
'===============================================================
Function init_permut(ByVal rng As Range, ByVal seln As Long) As Double
'順列リストを作成の初期化処理
'input rng 順列リスト作成する標本セル範囲
'    seln 抜き取り数
'output init_permut---順列数
  On Error Resume Next
  Dim g0 As Long
  Dim crng As Range
  p_svn = seln
  Erase p_myarray()
  Erase p_idx()
  g0 = 1
  ReDim p_myarray(1 To rng.Count)
  For Each crng In rng
   p_myarray(g0) = crng.Value
   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(rng.Count, seln)
End Function
'===============================================================
Function get_permut(ans(), Optional ByVal n_cnt As Long = 1) As Long
'init_permutの指定に基づく順列リストを取得する
'output ans() 順列リストを配列で出力する
'        予め必要な配列領域は呼び出し側で用意すること
'        尚、指定配列の添え字ベースは1とする
'    get_permut 0 正常に順列リストを取得 1 順列リストはなし
  Dim g0 As Long
  Dim g1 As Long
  Dim retcode As Long
  get_permut = 1
  For g0 = p_idx(n_cnt) To UBound(p_myarray())
    retcode = 0
    For g1 = LBound(p_idx()) To n_cnt - 1
     If p_idx(g1) = g0 Then
       retcode = 1
       Exit For
       End If
     Next g1
    If retcode = 0 Then
     ans(n_cnt) = p_myarray(g0)
     p_idx(n_cnt) = g0
     If n_cnt < UBound(p_idx()) Then
       get_permut = get_permut(ans(), n_cnt + 1)
     Else
       p_idx(n_cnt) = g0 + 1
       get_permut = 0
       End If
     End If
    If get_permut = 0 Then Exit For
    Next g0
  If get_permut = 1 Then
   p_idx(n_cnt) = 1
   End If
End Function
'===============================================================
Sub close_permut()
'順列リストを作成の終了処理
'(ファイルだって、Openすれば、クローズするよね)
  Erase p_myarray()
  Erase p_idx()
End Sub


これで、mainを実行してみてください。


セルA5から、文字aを含む3構成の順列リストが作成されるはずです。

後は、上記コードを検討して頂いて、仕様に合わせて改良してください。

【44405】Re:単語群による順列の生成
お礼  レイ E-MAIL  - 06/11/15(水) 9:40 -

引用なし
パスワード
   ichinoseさん。おはようございます。

大変参考になりました!
こんな朝早くに解決してしまうとは。
正直、ichinoseさんが羨ましく感じます。
どうもありがとうございます。

細かい仕様になったのは、
できるだけ解りやすくここに記載しなければ、
話が二転三転してしまうかな?
と思ったからでした。


それにしても素晴らしいです。
悩みだったファイルサイズがかなり軽くなりました。

どうもありがとうございました。

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