| |
くんくん さん、ちゃっぴさん、こんばんは。
>説明の付け足しです。
>日々、大幅に沢山の小幅を残幅が最小になる組み合わせを
>考えています。
>
>小幅は、前にも書いたとおりに、５刻みです。
>５００という大幅があれば、
>小幅は、ランダムにあって、
>305
>305
>125
>300
>50
>430
>430
>といった具合です。
>その与えられた小幅の中のみで、組み合わせを考え、
>残幅の少ないものから順に表示させたいです。
>データ量は、すごく多いという量ではありません。
>
>結果は、こんな感じにしたいです。
>430 50 (残20）
>305 125 (残70）
>430 (残70）
>305 (残195）
>300 (残200）
>これで、すべての小幅が組み合わされています。
まず、仕様です。
上の例題に値を固定してコードを書きました。
コードを見ていただければ、変更は可能かと思います。
アクティブシートのセルＡ１〜Ａ７に小幅メンバーの数値が入力して下さい。
A
1 305
2 305
3 125
4 300
5 50
6 430
7 430
この数値を入力して（値は変えてもかまいません）下記に記述してあるmainを実行して下さい。
Ｃ列 3行目からリストが表示され、Ｆ列には、差幅値（残幅）が表示されます。
では、コードです。
標準モジュール（Module1）に、
'====================================================================
Sub main()
Const 抜き取り = 2
Dim rng As Range
Dim 最小差幅リスト
Dim r_cnt As Long
Dim dsprow As Long
Dim nrng As Range
Dim 組み合わせ数 As Long
組み合わせ数 = 抜き取り
dsprow = 3
Set rng = Range("a1:a7") '小幅メンバセル範囲のセット
Do While Not rng Is Nothing
If rng.Count >= 抜き取り Then
組み合わせ数 = 抜き取り
Else
組み合わせ数 = rng.Count
End If
If get_min_comb(rng, 最小差幅リスト, 組み合わせ数, 500) = 0 Then
' ↑大幅の値を変更するならこの500を変更
wk = UBound(最小差幅リスト) - LBound(最小差幅リスト)
Range(Cells(dsprow, 3), Cells(dsprow, 3 + wk)).Value = 最小差幅リスト
Cells(dsprow, 6).Value = Evaluate("500-(" & Join(最小差幅リスト, "+") & ")")
dsprow = dsprow + 1
End If
Set rng = get_next_rng(rng, 最小差幅リスト)
' ↑表示したセル以外の範囲を設定
Loop
End Sub
'======================================================================
Function get_next_rng(rng, dellist) As Range
'指定されたセル範囲から、dellistに該当しないセルをひとつ削除する
ReDim rrng(1 To (UBound(dellist) - LBound(dellist) + 1)) As Range
For idx = LBound(dellist) To UBound(dellist)
Set rrng(idx) = Nothing
f_flg = 0
For Each crng In rng
If f_flg = 0 And crng.Value = dellist(idx) Then
f_flg = 1
Else
If Not rrng(idx) Is Nothing Then
Set rrng(idx) = Union(rrng(idx), crng)
Else
Set rrng(idx) = crng
End If
End If
Next
Next
Set get_next_rng = Nothing
For idx = LBound(rrng()) To UBound(rrng())
If Not rrng(idx) Is Nothing Then
If Not get_next_rng Is Nothing Then
Set get_next_rng = Application.Intersect(get_next_rng, rrng(idx))
Else
Set get_next_rng = rrng(idx)
End If
End If
Next idx
End Function
'=========================================================================
Function get_min_comb(rng As Range, myarray As Variant, 最大抜き取り数 As Long, 大幅 As Long) As Long
'指定されたセル範囲の組み合わせから大幅との差幅の小さい組み合わせを取得する
Dim idx As Long
Dim comb_list()
Dim ans()
Dim 差幅 As Long
get_max_comb = 1
差幅 = 大幅
For idx = 最大抜き取り数 To 1 Step -1
ReDim comb_list(1 To idx)
Call comb_init(rng, idx)
Do While get_comb(comb_list()) = 0
wk = Evaluate(大幅 & "-(" & Join(comb_list(), "+") & ")")
If Evaluate(大幅 & "-(" & Join(comb_list(), "+") & ")") >= 0 Then
If 差幅 > wk Then
差幅 = wk
Erase ans()
ans() = comb_list()
get_min_comb = 0
End If
End If
Loop
Next
If get_min_comb = 0 Then
myarray = ans()
End If
End Function
他の標準モジュール（Module2）に
'=======================================================================
Private c_svn As Long
Private c_myarray()
Private c_idx() As Long
Private cs_x() As Long
'=======================================================================
Function comb_init(rng As Range, seln As Long) As Double
'組み合わせ情報の初期化
c_svn = seln
Erase c_myarray
Erase c_idx
Erase cs_x()
i = 1
For Each crng In rng
ReDim Preserve c_myarray(1 To i)
c_myarray(i) = crng.Value
i = i + 1
Next
ReDim cs_x(1 To seln)
ReDim c_idx(1 To seln)
For i = 1 To UBound(c_idx())
cs_x(i) = i
c_idx(i) = i
Next
c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
comb_init = WorksheetFunction.Combin(rng.Count, seln)
End Function
'======================================================================
Function get_comb(ans()) As Long
'組み合わせメンバーの取得
get_comb = 1
For i = UBound(c_idx()) To LBound(c_idx()) Step -1
If c_idx(i) + 1 <= UBound(c_myarray()) - c_svn + i Then
c_idx(i) = c_idx(i) + 1
get_comb = 0
Exit For
Else
c_idx(i) = cs_x(i) + 1
cs_x(i) = cs_x(i) + 1
For j = i + 1 To UBound(cs_x())
cs_x(j) = cs_x(j - 1) + 1
c_idx(j) = cs_x(j)
Next j
End If
Next
If get_comb = 0 Then
For i = LBound(c_idx()) To UBound(c_idx())
ans(i) = c_myarray(c_idx(i))
Next
End If
End Function
以上です。
くんくん さんが都合の良いような変更は、mainプロシジャーの入力データの箇所の
変更でよいと思いますが・・・。
確認してみて下さい。
それから、次回からは、こういうアルゴリズムに関するようなご質問は
もう少し詳しく（例えば、例も最低3例ぐらい）記述して下さいね！！
|
|
ichinose
- 04/6/23(水) 19:21 -
