| |
おはようございます。
新規ブックにて試してみてください
標準モジュールに
'=================================================================
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を実行してください。
|
|
ichinose
- 09/7/30(木) 8:28 -
