| |
こんばんは。
一週間たってしまいましたね・・・。
私も作ったので、よかったら検証してみてください。
まず、標準モジュール（Module1）に
'========================================================
Sub test()
Dim 組合せ
Dim 組み分け数 As Long
組み分け数 = 3
in_array = Array("A", "B", "C", "D", "E", "F", "G", "H")
Call mk_pat_init(UBound(in_array) - LBound(in_array) + 1, 組み分け数)
st = 1
jdx = 1
Do While mk_pat(pat) = 0
組合せ = dist_array(in_array, "", 組み分け数, pat)
Range(Cells(st, 1), Cells(st + UBound(組合せ, 1), 組み分け数)).Value = _
組合せ
st = st + UBound(組合せ, 1) + 1
Loop
End Sub
'=======================================================================
Function dist_array(ByVal in_array, ByVal delimter As String, ByVal 組み分け数 As Long, ByVal patturn, _
Optional ByVal pdx As Long = 0, Optional ByVal nest As Long = 0, Optional ByVal dupmd As Long = 0)
'指定された配列を指定された組み分け数でグループ化する
'グループ化の詳細は、配列Patturnの値による
'input : in_array ----組み分け数配列（１次元配列)
' delimiter---同一グループ内を区切る文字
' 組み分け数---グループ化する数
' patturnグループメンバ数等の情報（２次元配列）
'
'
'output : dist_array ２次元配列 1次元目がメンバ数
' 2次元目がグループ化されたメンバの組合せ
'pdx nest dupmdは、指定不可 内部処理データ
Static dup() As Class1
Static ans()
Static adx As Long
Static c_array()
If nest = 0 Then
menum = 1
d_cnt = UBound(in_array) - LBound(in_array) + 1
With WorksheetFunction
For ll = LBound(patturn) To UBound(patturn)
For jj = 1 To patturn(ll, 1)
menum = menum * .Combin(d_cnt, patturn(ll, 0))
d_cnt = d_cnt - patturn(ll, 0)
Next jj
menum = menum / .Fact(patturn(ll, 1))
Next ll
End With
ReDim ans(menum - 1, 組み分け数 - 1)
ReDim c_array(組み分け数 - 1)
ReDim dup(UBound(in_array))
adx = 0
pdx = 0
If patturn(pdx, 1) > 1 Then
dupmd = 1
Else
dupmd = 0
End If
End If
If patturn(pdx, 1) = 0 Then
If pdx + 1 <= UBound(patturn, 1) Then
pdx = pdx + 1
If patturn(pdx, 1) > 1 Then
dupmd = 1
Else
dupmd = 0
End If
Else
Exit Function
End If
End If
If dupmd >= 1 Then
Set dup(nest) = New Class1
dup(nest).duparray_init UBound(in_array)
End If
patturn(pdx, 1) = patturn(pdx, 1) - 1
myarray1 = combin_list(in_array, patturn(pdx, 0))
For idx = LBound(myarray1, 1) To UBound(myarray1, 1)
ReDim tmp(UBound(myarray1, 2))
For jdx = LBound(myarray1, 2) To UBound(myarray1, 2)
tmp(jdx) = myarray1(idx, jdx)
Next jdx
retcode = 0
If dupmd > 1 Then
For dpx = nest - dupmd + 1 To nest - 1
retcode = dup(dpx).duparray_chk(tmp())
If retcode <> 0 Then Exit For
Next dpx
End If
If retcode = 0 Then
If dupmd >= 1 Then
dup(nest).duparray_put myarray1(idx, 0)
End If
c_array(nest) = Join(tmp(), delimter)
If nest = 組み分け数 - 1 Then
For kdx = LBound(c_array()) To UBound(c_array())
ans(adx, kdx) = c_array(kdx)
Next kdx
adx = adx + 1
End If
myarray2 = except_array(in_array, tmp())
Erase tmp()
Call dist_array(myarray2, delimter, 組み分け数, patturn, pdx, nest + 1, dupmd + 1)
End If
Next idx
If nest = 0 Then
dist_array = ans()
Erase ans()
Erase c_array()
On Error Resume Next
For idx = UBound(dup()) To LBound(dup())
If Not dup(idx) Is Nothing Then
dup(idx).duparray_term
End If
Set dup(idx) = Nothing
Next
Erase dup()
On Error GoTo 0
End If
End Function
'=======================================================================
Function except_array(in_array, exarray()) As Variant
'指定された配列から、指定された配列メンバを除いた配列を返す
'input : in_array 対象の配列（１次元配列）
' exarray() 取り除くメンバを含んだ配列（１次元配列）
'output: except_array -取り除かれた配列
Dim n_array()
Dim jdx As Long
Dim ok As Boolean
For idx = LBound(in_array) To UBound(in_array)
ok = True
For ex = LBound(exarray()) To UBound(exarray())
If in_array(idx) = exarray(ex) Then
ok = False
Exit For
End If
Next ex
If ok = True Then
ReDim Preserve n_array(jdx)
n_array(jdx) = in_array(idx)
jdx = jdx + 1
End If
Next
except_array = n_array()
End Function
'========================================
Function combin_list(総リスト, 抜取り数, Optional ByVal nest As Long = 0, Optional ByVal st As Long = 0)
'組合せリストを作成する
'input :総リスト----組合せリストを作成する元リスト（１次元の配列）
' 抜取り数----組合せ抜取り数
' nest及び、stは、指定不可 内部で使用するパラメータ
'output:combin_list---組合せリスト２次元配列
Static ans()
Static idx() As Long
Static jdx As Long
If nest = 0 Then
jdx = 0
ReDim idx(抜取り数 - 1)
ReDim ans(WorksheetFunction.Combin(UBound(総リスト) - LBound(総リスト) + 1, 抜取り数) - 1, 抜取り数 - 1)
st = LBound(総リスト)
End If
For idx(nest) = st To UBound(総リスト)
If nest < 抜取り数 - 1 Then
Call combin_list(総リスト, 抜取り数, nest + 1, idx(nest) + 1)
Else
For kdx = 0 To 抜取り数 - 1
ans(jdx, kdx) = 総リスト(idx(kdx))
Next kdx
jdx = jdx + 1
End If
Next
If nest = 0 Then
combin_list = ans()
End If
End Function
'*****************************************
'別の標準モジュール（Module2）に
'======================================================================
Private d_ans As Long
Private d_mem() As Long
Private d_idx() As Long
Sub mk_pat_init(ans As Long, num As Long)
'分配パターンを作成する初期化
ReDim d_mem(1 To ans - 1)
ReDim d_idx(1 To num)
For idx = LBound(d_mem()) To UBound(d_mem())
d_mem(idx) = idx
Next
For idx = LBound(d_idx()) To UBound(d_idx())
d_idx(idx) = 1
Next
d_idx(UBound(d_idx())) = 0
d_ans = ans
End Sub
'========================================================================
Function mk_pat(patturn)
'分配パターンを作成する
Dim mk_pat_ok As Long
Dim wkc As Collection
Dim a_num()
mk_pat = 1
Do While mk_pat_ok = 0
mk_pat_ok = 1
For idx = UBound(d_idx()) To LBound(d_idx()) Step -1
If d_idx(idx) + 1 > UBound(d_mem()) Then
d_idx(idx) = 1
Else
mk_pat_ok = 0
d_idx(idx) = d_idx(idx) + 1
Exit For
End If
Next idx
If mk_pat_ok = 0 Then
ok = 0
jdx = 0
wk = d_mem(d_idx(UBound(d_idx())))
For idx = LBound(d_idx()) To UBound(d_idx()) - 1
If d_mem(d_idx(idx)) > d_mem(d_idx(idx + 1)) Then
ok = 1
Exit For
Else
If d_mem(d_idx(idx)) < d_mem(d_idx(idx + 1)) Then jdx = jdx + 1
wk = wk + d_mem(d_idx(idx))
End If
Next idx
If ok = 0 And wk = d_ans Then
Set wkc = New Collection
ReDim a_num(jdx, 1)
jdx = 0
On Error Resume Next
With wkc
For idx = LBound(d_idx()) To UBound(d_idx())
Err.Clear
.Add d_mem(d_idx(idx)), Str(d_mem(d_idx(idx)))
If Err.Number = 0 Then
a_num(jdx, 0) = d_mem(d_idx(idx))
a_num(jdx, 1) = 1
jdx = jdx + 1
Else
a_num(jdx - 1, 1) = a_num(jdx - 1, 1) + 1
End If
Next idx
End With
On Error GoTo 0
patturn = a_num()
mk_pat = 0
Exit Do
Else
mk_pat_ok = 0
End If
End If
Loop
End Function
'******************************************************************
'最後にクラスモジュール（クラス名は、Class1）を
'====================================================================
Private duparray() '重複チェック用配列
Private fdx As Long '配列のポインタ
'=====================================================================
Sub duparray_init(array_num As Long) '重複チェックを初期化
ReDim duparray(array_num)
For idx = LBound(duparray()) To UBound(duparray())
duparray(idx) = ""
Next idx
fdx = 0
End Sub
'================================================================
Sub duparray_term()
'重複チェックの終わり
On Error Resume Next
Erase duparray()
End Sub
'=================================================================
Sub duparray_put(myvalue)
'チェックメンバの追加
Dim menflg As Boolean
menflg = True
For idx = LBound(duparray()) To fdx - 1
If duparray(idx) = myvalue Then
menflg = False
Exit For
End If
Next idx
If menflg = True Then
duparray(fdx) = myvalue
fdx = fdx + 1
End If
End Sub
'==================================================================
Function duparray_chk(myvalue()) As Long
'重複のチェック
'out duparray_chk 0--重複なし 1--重複あり
duparray_chk = 0
For idx = LBound(duparray()) To fdx - 1
For jdx = LBound(myvalue) To UBound(myvalue)
If duparray(idx) = myvalue(jdx) Then
duparray_chk = 1
Exit For
End If
Next jdx
If duparray_chk = 1 Then Exit For
Next idx
End Function
以上です。testを実行してみて下さい。
これ、結構、難しいねえ・・・、もっと簡単だと思ってました。
|
|
ichinose
- 04/11/20(土) 0:29 -
