| |
▼レイ さん：
おはようございます。
細かい仕様に不明な点がありますが、
この問題、順列リストが作成できれば、処理の早い遅いの差はあっても
概ね出来そうですけどね！！
順列リスト作成するコードは以前作ったことがあります。
こんな例を考えます。
アクティブシートの
セルＡ１〜Ｅ１にそれぞれ
a b c d e
というアルファベットが入っています。
（これは、アクティブシートのA1〜E1に予め入力して置いてください）
この５個の文字から３を抜き出す順列リストを考えます。
但し、aという文字は必ず入っていること。
順列リストは、セルＡ５から、下行に書き出すことにします。
標準モジュールに
'===============================================================
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を実行してみてください。
セルＡ５から、文字aを含む３構成の順列リストが作成されるはずです。
後は、上記コードを検討して頂いて、仕様に合わせて改良してください。
|
|
ichinose
- 06/11/15(水) 7:49 -
